pax_global_header00006660000000000000000000000064150161661340014515gustar00rootroot0000000000000052 comment=f8035fdf9ce8a995579d21c16480b11530a6e7e9 base_quickcheck-0.17.1/000077500000000000000000000000001501616613400147075ustar00rootroot00000000000000base_quickcheck-0.17.1/.gitignore000066400000000000000000000000411501616613400166720ustar00rootroot00000000000000_build *.install *.merlin _opam base_quickcheck-0.17.1/.ocamlformat000066400000000000000000000000231501616613400172070ustar00rootroot00000000000000profile=janestreet base_quickcheck-0.17.1/CHANGES.md000066400000000000000000000017031501616613400163020ustar00rootroot00000000000000## Release v0.17.0 - Add Bigarray distribution functions to `Generator`: * `Generator.bigarray1` * `Generator.bigstring_with_length` * `Generator.float32_vec_with_length` * `Generator.float64_vec_with_length` - Update the type of `Generator.create` and `Generator.generate` to use `Splittable_random.t` instead of `Splittable_random.State.t`. The former is simply a shorter alias for the latter. - Remove `[@@deriving fields]` from `Test.Config.t` to reduce bloat. - Add flags for individual components to `ppx_quickcheck` e.g. `[@@deriving quickcheck ~generator ~observer ~shrinker]`. ## Release v0.16.0 - Add new geometric distributions for integer types to `Generator`: * All functions take a minimum value and a probability `p` as parameters, producing a geometric distribution * Raise an error if `p <. 0. || 1. <. p` - Add `string_like` function to `Generator`: * Produces strings similar to a given input with some number of edits base_quickcheck-0.17.1/CONTRIBUTING.md000066400000000000000000000044101501616613400171370ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ base_quickcheck-0.17.1/LICENSE.md000066400000000000000000000021461501616613400163160ustar00rootroot00000000000000The MIT License Copyright (c) 2018--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. base_quickcheck-0.17.1/Makefile000066400000000000000000000004031501616613400163440ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean base_quickcheck-0.17.1/base_quickcheck.opam000066400000000000000000000023411501616613400206710ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.1" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/base_quickcheck" bug-reports: "https://github.com/janestreet/base_quickcheck/issues" dev-repo: "git+https://github.com/janestreet/base_quickcheck.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/base_quickcheck/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppx_base" {>= "v0.17" & < "v0.18"} "ppx_fields_conv" {>= "v0.17" & < "v0.18"} "ppx_let" {>= "v0.17" & < "v0.18"} "ppx_sexp_message" {>= "v0.17" & < "v0.18"} "ppx_sexp_value" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "splittable_random" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.36.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Randomized testing framework, designed for compatibility with Base" description: " Base_quickcheck provides randomized testing in the style of Haskell's Quickcheck library, with support for built-in types as well as types provided by Base. " base_quickcheck-0.17.1/dune-project000066400000000000000000000000211501616613400172220ustar00rootroot00000000000000(lang dune 3.11) base_quickcheck-0.17.1/examples/000077500000000000000000000000001501616613400165255ustar00rootroot00000000000000base_quickcheck-0.17.1/examples/base_quickcheck_examples.ml000066400000000000000000000000621501616613400240570ustar00rootroot00000000000000(*_ This library deliberately exports nothing. *) base_quickcheck-0.17.1/examples/custom_distribution.ml000066400000000000000000000141121501616613400231670ustar00rootroot00000000000000open! Base open Base_quickcheck module _ : sig type t = | Nullary | Unary of bool | Binary of int * float | N_ary of string list [@@deriving quickcheck] end = struct type t = | Nullary | Unary of bool | Binary of int * float | N_ary of string list [@@deriving compare, quickcheck, sexp_of] (* Perhaps we want more examples of the variants with more contents. We can override the default derived generator with one that uses [Generator.weighted_union] to skew the distribution. *) let quickcheck_generator = Generator.weighted_union [ 1., Generator.return Nullary ; 2., [%quickcheck.generator: bool] |> Generator.map ~f:(fun bool -> Unary bool) ; ( 4. , [%quickcheck.generator: int * float] |> Generator.map ~f:(fun (int, float) -> Binary (int, float)) ) ; ( 10. , [%quickcheck.generator: string list] |> Generator.map ~f:(fun list -> N_ary list) ) ] ;; (* We can test our distribution: *) let%expect_test _ = let open Expect_test_helpers_core in Test.with_sample_exn quickcheck_generator ~config:{ Test.default_config with test_count = 20 } ~f:(fun sequence -> sequence |> Sequence.to_list |> List.sort ~compare |> List.map ~f:sexp_of_t |> List.iter ~f:print_s); [%expect {| Nullary Nullary (Binary -58823712978749242 1.326895442392441E+36) (Binary -192459552073625 2.75) (Binary 85 -0) (Binary 52814 11.770832120594708) (Binary 870067995 1048576) (Binary 1757545005705 -13.928729046486296) (Binary 195313760848289 -1.75) (Binary 1215235890521588953 1.7728695309706382) (N_ary ()) (N_ary ()) (N_ary ("")) (N_ary ("" "" "" "" "" "" "\222" y @)) (N_ary (5K 2)) (N_ary (B Mh)) (N_ary (DM)) (N_ary (L7N)) (N_ary (bAW6zR `y7O 1V7)) (N_ary ("\219\171nqZ" "asa\250Y")) |}] ;; end module _ : sig type t = { rationals : float list ; index : int } [@@deriving quickcheck] end = struct type t = { rationals : float list ; index : int } [@@deriving compare, quickcheck, sexp_of] (* We might want to choose [rationals] from a distribution of finite floats, and for [index] to be a legal index into [rationals]. We can override the default derived generator with one that uses and some custom distributions, as well as [Generator.bind] so the choice of [index] can depend on the choice of [rationals]. *) let quickcheck_generator = let open Generator.Let_syntax in let%bind rationals = Generator.list_non_empty Generator.float_positive_or_zero in let%bind index = Generator.int_uniform_inclusive 0 (List.length rationals - 1) in return { rationals; index } ;; (* We can test our distribution: *) let%expect_test _ = let open Expect_test_helpers_core in Test.with_sample_exn quickcheck_generator ~config:{ Test.default_config with test_count = 20 } ~f:(fun sequence -> sequence |> Sequence.to_list |> List.sort ~compare |> List.stable_sort ~compare:(fun a b -> Comparable.lift Int.ascending ~f:(fun t -> List.length t.rationals) a b) |> List.map ~f:sexp_of_t |> List.iter ~f:print_s); [%expect {| ((rationals (2.8280262305352377E-308)) (index 0)) ((rationals (4.2366697150646817E-308)) (index 0)) ((rationals (1.3789672079675011E-186)) (index 0)) ((rationals (0.01171875)) (index 0)) ((rationals (1.9795913696289062)) (index 0)) ((rationals (2.75)) (index 0)) ((rationals (8)) (index 0)) ((rationals (8)) (index 0)) ((rationals (1157627904)) (index 0)) ((rationals (6.1431989399976011E+106)) (index 0)) ((rationals (5.5427886579169E+199)) (index 0)) ((rationals (9.90958590546204E+307)) (index 0)) ((rationals (1.7550194473742371E+308)) (index 0)) ((rationals (0.8616666835732758 1.1385925121758191)) (index 1)) ((rationals (2.8237828741950466E-13 1.8224854137420152 0.01824775352821284)) (index 2)) ((rationals (1.7976931348614984E+308 0.05622608376936 0.466064453125)) (index 2)) ((rationals ( 1.6166417891736373E-20 2.2250738585072009E-308 6.27752527870636E-24 1.7360032353802967E+308 0.36672276957627137 59045.107299804688 2.9870388295270649E+111 3.5407791527709811E-308 2853992448 2.20056001438752 1.9901765337663721E+76 18014397435740160 5.007667344459188E+230 2.0470928690338857E+18)) (index 11)) ((rationals ( 1.40631103515625 0.99999618530273438 0.14919622650404563 9.470385479937987E+307 3.4916006318991669E+46 7.144487913378675E+94 6.1754202605911972E-23 5.1212177483591671E+252 0.19299798905001353 3.0922966003417969 1.07706310793392E-321 3.5288404323765937E-71 192 1.5763809981878558E+308)) (index 9)) ((rationals ( 1.0061122386630193E-15 1.2983366397190109E+274 1.5967894544723646E-20 5.8227197141673614E-25 1.05190200652924E-313 5.2438958771526814 1.1424624566895193E+280 446422.03912734985 1.7807147461350098E+308 0.84189605712890625 9.8710317674614133E-178 1.6875 2.79233146312789E-16 4.6931086289980425E-05 4.46562265651841E+101 3.75)) (index 5)) ((rationals ( 23828.06884765625 1.3858716369066866E-143 7.9926092692070288E-33 0.0060125291347503662 5.2492643594741821 2.9802322359939737E-08 0.00014042180987416941 3.638671875 1.28993722023237E-317 7.242851245042631E-12 0.062499999534338713 0.002296784776262939 237.88091122743026 2.2765450197646858E-274 126.14432978630066 2.716326520622772E+60)) (index 6)) |}] ;; end base_quickcheck-0.17.1/examples/custom_distribution.mli000066400000000000000000000000551501616613400233410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base_quickcheck-0.17.1/examples/deriving.ml000066400000000000000000000060411501616613400206670ustar00rootroot00000000000000open! Base open Base_quickcheck (* We define numeric types for rational, real, and complex values derived from ints and floats. We derive quickcheck definitions for our types. *) type rational = | Integer of int | Rational of { numerator : int ; denominator : int } [@@deriving compare, quickcheck, sexp_of] type real = | Rational of rational | Float of float [@@deriving compare, quickcheck, sexp_of] type number = | Real of real | Complex of real * real [@@deriving compare, quickcheck, sexp_of] (* We define addition for our types. *) let numerator = function | Integer n -> n | Rational x -> x.numerator ;; let denominator = function | Integer _ -> 1 | Rational x -> x.denominator ;; let add_rational x y = match x, y with | Integer x, Integer y -> Integer (x + y) | _ -> let nx = numerator x in let dx = denominator x in let ny = numerator y in let dy = denominator y in let numerator = (nx * dy) + (ny * dx) in let denominator = dy * dx in Rational { numerator; denominator } ;; let rational_float = function | Integer int -> Float.of_int int | Rational x -> Float.of_int x.numerator /. Float.of_int x.denominator ;; let real_float = function | Rational rational -> rational_float rational | Float float -> float ;; let add_real x y = match x, y with | Rational x, Rational y -> Rational (add_rational x y) | _ -> Float (real_float x +. real_float y) ;; let real_part = function | Real real -> real | Complex (real, _) -> real ;; let imaginary_part = function | Real _ -> Rational (Integer 0) | Complex (_, imaginary) -> imaginary ;; let add_number x y = match x, y with | Real x, Real y -> Real (add_real x y) | _ -> let real = add_real (real_part x) (real_part y) in let imaginary = add_real (imaginary_part x) (imaginary_part y) in Complex (real, imaginary) ;; (* We test some properties of our addition operation. *) let%test_unit "commutativity" = Test.run_exn (module struct type t = number * number [@@deriving quickcheck, sexp_of] end) ~f:(fun (x, y) -> [%test_eq: number] (add_number x y) (add_number y x)) ;; let%test_unit "left identity" = Test.run_exn (module struct type t = number [@@deriving quickcheck, sexp_of] end) ~f:(fun x -> [%test_eq: number] x (add_number (Real (Rational (Integer zero))) x)) ;; let%test_unit "right identity" = Test.run_exn (module struct type t = number [@@deriving quickcheck, sexp_of] end) ~f:(fun x -> [%test_eq: number] x (add_number x (Real (Rational (Integer zero))))) ;; (* Our implementation does not satisfy associativity. For example, floating point rounding errors can break it. *) let%test_unit "associativity is broken" = assert ( Exn.does_raise (fun () -> Test.run_exn (module struct type t = number * number * number [@@deriving quickcheck, sexp_of] end) ~f:(fun (x, y, z) -> [%test_eq: number] (add_number x (add_number y z)) (add_number (add_number x y) z)))) ;; base_quickcheck-0.17.1/examples/deriving.mli000066400000000000000000000000541501616613400210360ustar00rootroot00000000000000(*_ This signature is deliberately empty *) base_quickcheck-0.17.1/examples/dune000066400000000000000000000002201501616613400173750ustar00rootroot00000000000000(library (name base_quickcheck_examples) (libraries async base base_quickcheck core expect_test_helpers_core) (preprocess (pps ppx_jane))) base_quickcheck-0.17.1/examples/from_comments.ml000066400000000000000000000005771501616613400217400ustar00rootroot00000000000000open Core open Quickcheck.Observer type 'a bst = | Leaf | Node of 'a bst * 'a * 'a bst let bst_obs key_obs = fixed_point (fun bst_of_key_obs -> unmap (Either.quickcheck_observer Unit.quickcheck_observer (tuple3 bst_of_key_obs key_obs bst_of_key_obs)) ~f:(function | Leaf -> First () | Node (l, k, r) -> Second (l, k, r))) ;; base_quickcheck-0.17.1/examples/from_docs.ml000066400000000000000000000304651501616613400210420ustar00rootroot00000000000000open Core open Quickcheck module Initial_example = struct let%test_unit "fold_left vs fold_right" = Quickcheck.test (List.quickcheck_generator Int.quickcheck_generator) ~sexp_of:[%sexp_of: int list] ~f:(fun list -> [%test_eq: int] (List.fold_left ~init:0 ~f:( + ) list) (List.fold_right ~init:0 ~f:( + ) list)) ;; end module Generator_examples = struct let (_ : _ Generator.t) = Generator.singleton "An arbitrary value." let (_ : _ Generator.t) = String.quickcheck_generator (* any string, including weird strings like "\000" *) let (_ : _ Generator.t) = Int.quickcheck_generator (* any int, from [min_value] to [max_value] *) let (_ : _ Generator.t) = Float.quickcheck_generator (* any float, from [neg_infinity] to [infinity] plus [nan] *) let (_ : _ Generator.t) = Generator.small_non_negative_int let (_ : _ Generator.t) = Generator.small_positive_int let (_ : _ Generator.t) = Int.gen_incl 0 99 let (_ : _ Generator.t) = Int.gen_uniform_incl 0 99 let (_ : _ Generator.t) = Float.gen_incl 1. 100. let (_ : _ Generator.t) = Float.gen_finite let (_ : _ Generator.t) = Generator.tuple2 Int.quickcheck_generator Float.quickcheck_generator ;; let (_ : _ Generator.t) = List.quickcheck_generator (Generator.tuple2 Int.quickcheck_generator Float.quickcheck_generator) ;; let (_ : _ Generator.t) = List.gen_with_length 12 (Generator.tuple2 Int.quickcheck_generator Float.quickcheck_generator) ;; let (_ : _ Generator.t) = Either.quickcheck_generator Int.quickcheck_generator Float.quickcheck_generator ;; let (_ : _ Generator.t) = Option.quickcheck_generator String.quickcheck_generator let (_ : _ Generator.t) = Generator.map Char.quickcheck_generator ~f:Char.to_int let (_ : _ Generator.t) = Generator.filter Float.quickcheck_generator ~f:Float.is_finite (* use [filter] sparingly! *) let (_ : _ Generator.t) = Generator.fn Int.quickcheck_observer Bool.quickcheck_generator let (_ : _ Generator.t) = Generator.(union [ singleton (Ok ()); singleton (Or_error.error_string "fail") ]) ;; module Monadic = struct let (_ : _ Generator.t) = let open Generator in String.quickcheck_generator >>= fun str -> Int.gen_incl 0 (String.length str - 1) >>| fun i -> str, i, str.[i] ;; end module Recursive = struct let (_ : _ Generator.t) = Generator.( fixed_point (fun self -> size >>= function | 0 -> String.quickcheck_generator >>| fun atom -> Sexp.Atom atom | _ -> List.quickcheck_generator self >>| fun list -> Sexp.List list)) ;; let rec binary_subtree lower_bound upper_bound = let open Generator in if lower_bound > upper_bound then singleton `Leaf else union [ singleton `Leaf ; (Int.gen_incl lower_bound upper_bound >>= fun key -> binary_subtree lower_bound (key - 1) >>= fun left -> binary_subtree (key + 1) upper_bound >>| fun right -> `Node (left, key, right) ) ] ;; let _binary_tree : _ Generator.t = binary_subtree Int.min_value Int.max_value let rec powers_of_two_starting_from x = let open Generator in union [ singleton x; of_fun (fun () -> powers_of_two_starting_from (x *. 2.)) ] ;; let _powers_of_two : _ Generator.t = powers_of_two_starting_from 1. end end module Observer_examples = struct let (_ : _ Observer.t) = Observer.singleton () let (_ : _ Observer.t) = String.quickcheck_observer let (_ : _ Observer.t) = Int.quickcheck_observer let (_ : _ Observer.t) = Float.quickcheck_observer let (_ : _ Observer.t) = Observer.tuple2 Int.quickcheck_observer Float.quickcheck_observer ;; let (_ : _ Observer.t) = List.quickcheck_observer (Observer.tuple2 Int.quickcheck_observer Float.quickcheck_observer) ;; let (_ : _ Observer.t) = Either.quickcheck_observer Int.quickcheck_observer Float.quickcheck_observer ;; let (_ : _ Observer.t) = Option.quickcheck_observer String.quickcheck_observer let (_ : _ Observer.t) = Observer.fn Int.quickcheck_generator Bool.quickcheck_observer let (_ : _ Observer.t) = Observer.unmap Char.quickcheck_observer ~f:Char.of_int_exn end module Example_1_functional = struct module Functional_stack : sig type 'a t [@@deriving sexp, compare] val empty : _ t val is_empty : _ t -> bool val push : 'a t -> 'a -> 'a t val top_exn : 'a t -> 'a val pop_exn : 'a t -> 'a t end = struct type 'a t = 'a list [@@deriving sexp, compare] let empty = [] let is_empty = List.is_empty let push t x = x :: t let top_exn = function | [] -> failwith "empty stack" | x :: _ -> x ;; let pop_exn = function | [] -> failwith "empty stack" | _ :: t -> t ;; end let of_list list = List.fold list ~init:Functional_stack.empty ~f:Functional_stack.push let stack elt = Generator.map (List.quickcheck_generator elt) ~f:of_list open Functional_stack let%test_unit "push + is_empty" = Quickcheck.test (Generator.tuple2 Int.quickcheck_generator (stack Int.quickcheck_generator)) ~f:(fun (x, t) -> [%test_result: bool] (is_empty (push t x)) ~expect:false) ;; let%test_unit "push + top_exn" = Quickcheck.test (Generator.tuple2 Int.quickcheck_generator (stack Int.quickcheck_generator)) ~f:(fun (x, t) -> [%test_result: int] (top_exn (push t x)) ~expect:x) ;; let%test_unit "push + pop_exn" = Quickcheck.test (Generator.tuple2 Int.quickcheck_generator (stack Int.quickcheck_generator)) ~f:(fun (x, t) -> [%test_result: int t] (pop_exn (push t x)) ~expect:t) ;; end module Example_2_imperative = struct module Imperative_stack : sig type 'a t [@@deriving sexp, compare] val create : unit -> _ t val is_empty : _ t -> bool val push : 'a t -> 'a -> unit val pop_exn : 'a t -> 'a val iter : 'a t -> f:('a -> unit) -> unit val to_list : 'a t -> 'a list end = struct type 'a t = 'a list ref [@@deriving sexp, compare] let create () = ref [] let is_empty t = List.is_empty !t let push t x = t := x :: !t let pop_exn t = match !t with | [] -> failwith "empty stack" | x :: list -> t := list; x ;; let to_list t = !t let iter t ~f = List.iter !t ~f end let stack elt = let open Generator in List.quickcheck_generator elt >>| fun xs -> let t = Imperative_stack.create () in List.iter xs ~f:(fun x -> Imperative_stack.push t x); t ;; open Imperative_stack let%test_unit "push + is_empty" = Quickcheck.test (Generator.tuple2 String.quickcheck_generator (stack String.quickcheck_generator)) ~f:(fun (x, t) -> [%test_result: bool] (push t x; is_empty t) ~expect:false) ;; let%test_unit "push + pop_exn" = Quickcheck.test (Generator.tuple2 String.quickcheck_generator (stack String.quickcheck_generator)) ~f:(fun (x, t) -> push t x; let y = pop_exn t in [%test_result: string] y ~expect:x) ;; let%test_unit "push + to_list" = Quickcheck.test (Generator.tuple2 String.quickcheck_generator (stack String.quickcheck_generator)) ~f:(fun (x, t) -> let list1 = to_list t in push t x; let list2 = to_list t in [%test_result: string list] list2 ~expect:(x :: list1)) ;; let%test_unit "push + pop_exn + to_list" = Quickcheck.test (Generator.tuple2 String.quickcheck_generator (stack String.quickcheck_generator)) ~f:(fun (x, t) -> let list1 = to_list t in push t x; let (_ : string) = pop_exn t in let list2 = to_list t in [%test_result: string list] list2 ~expect:list1) ;; let%test_unit "iter" = Quickcheck.test (stack String.quickcheck_generator) ~f:(fun t -> let q = Queue.create () in iter t ~f:(fun x -> Queue.enqueue q x); [%test_result: string list] (Queue.to_list q) ~expect:(to_list t)) ;; end module Example_3_asynchronous = struct open Async module Async_stack : sig type 'a t [@@deriving sexp, compare] val create : unit -> _ t val is_empty : 'a t -> bool val push : 'a t -> 'a -> unit Deferred.t (* pushback until stack empties *) val pop : 'a t -> 'a Deferred.t (* wait until element is available *) val iter : 'a t -> f:('a -> unit Deferred.t) -> unit Deferred.t val to_list : 'a t -> 'a list end = struct type 'a t = { mutable elts : 'a list ; mutable push : unit Ivar.t ; mutable pops : 'a Ivar.t list } let of_list elts = { elts ; push = (if List.is_empty elts then Ivar.create_full () else Ivar.create ()) ; pops = [] } ;; let to_list t = t.elts let sexp_of_t sexp_of_elt t = [%sexp_of: elt list] (to_list t) let t_of_sexp elt_of_sexp sexp = of_list ([%of_sexp: elt list] sexp) let compare (type elt) compare_elt t1 t2 = [%compare: elt list] t1.elts t2.elts let create () = of_list [] let is_empty t = List.is_empty t.elts let push_without_pushback t x = match t.pops with | ivar :: rest -> t.pops <- rest; Ivar.fill_exn ivar x | [] -> if Ivar.is_full t.push then t.push <- Ivar.create (); t.elts <- x :: t.elts ;; let push t x = push_without_pushback t x; Ivar.read t.push ;; let pop t = match t.elts with | [] -> let ivar = Ivar.create () in t.pops <- ivar :: t.pops; Ivar.read ivar | x :: rest -> t.elts <- rest; if List.is_empty rest then Ivar.fill_exn t.push (); Deferred.return x ;; let iter t ~f = Deferred.List.iter ~how:`Sequential t.elts ~f end let stack elt = let open Generator in List.quickcheck_generator elt >>| fun xs -> let t = Async_stack.create () in List.iter xs ~f:(fun x -> don't_wait_for (Async_stack.push t x)); t ;; open Async_stack let%test_unit "push + is_empty" = Quickcheck.test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> don't_wait_for (push t x); [%test_result: bool] (is_empty t) ~expect:false) ;; let%test_unit "push + to_list" = Quickcheck.test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> let list1 = to_list t in don't_wait_for (push t x); let list2 = to_list t in [%test_result: char list] list2 ~expect:(x :: list1)) ;; let%test_unit "push + pushback" = Quickcheck.test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> let pushback = push t x in [%test_result: bool] (Deferred.is_determined pushback) ~expect:false) ;; let%test_unit "push + pop" = Thread_safe.block_on_async_exn (fun () -> Quickcheck.async_test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> don't_wait_for (push t x); pop t >>| fun y -> [%test_result: char] y ~expect:x)) ;; let%test_unit "push + pop + to_list" = Thread_safe.block_on_async_exn (fun () -> Quickcheck.async_test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> let list1 = to_list t in don't_wait_for (push t x); pop t >>| fun _ -> let list2 = to_list t in [%test_result: char list] list2 ~expect:list1)) ;; let%test_unit "iter" = Thread_safe.block_on_async_exn (fun () -> Quickcheck.async_test (stack Char.quickcheck_generator) ~f:(fun t -> let q = Queue.create () in iter t ~f:(fun x -> Queue.enqueue q x; Deferred.unit) >>| fun () -> [%test_result: char list] (Queue.to_list q) ~expect:(to_list t))) ;; let%test_unit "push + pop + pushback" = Thread_safe.block_on_async_exn (fun () -> Quickcheck.async_test (Generator.tuple2 Char.quickcheck_generator (stack Char.quickcheck_generator)) ~f:(fun (x, t) -> let pushback = push t x in pop t >>| fun _ -> [%test_result: bool] (Deferred.is_determined pushback) ~expect:(is_empty t))) ;; end base_quickcheck-0.17.1/examples/from_webpage.ml000066400000000000000000000006431501616613400215170ustar00rootroot00000000000000open Base open Base_quickcheck type complex = { real : float ; imaginary : float } [@@deriving compare, quickcheck, sexp] let add x y = { real = x.real +. y.real; imaginary = x.imaginary +. y.imaginary } let%expect_test "commutativity" = Test.run_exn (module struct type t = complex * complex [@@deriving quickcheck, sexp] end) ~f:(fun (x, y) -> [%test_eq: complex] (add x y) (add y x)) ;; base_quickcheck-0.17.1/examples/from_webpage.mli000066400000000000000000000000551501616613400216650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base_quickcheck-0.17.1/examples/from_wiki.ml000066400000000000000000000024311501616613400210450ustar00rootroot00000000000000open Core open Poly open Quickcheck let%test_unit "count vs length" = Quickcheck.test (* (\* Initial example that fails on NaN: *\) * (List.gen Float.gen) *) (* Working example that filters out NaN: *) (List.quickcheck_generator (Generator.filter Float.quickcheck_generator ~f:(Fn.non Float.is_nan))) (* (\* Simplest version: *\) * (List.gen Float.gen_without_nan) *) ~sexp_of:[%sexp_of: float list] ~f:(fun float_list -> [%test_result: int] (List.count float_list ~f:(fun x -> x = x)) ~expect:(List.length float_list)) ;; let list_gen elt_gen = (* Rely on [Generator.recursive_union] to reduce the size on recursive calls. This generator skews toward larger elements near the head of the list. *) Generator.( recursive_union [ return [] ] ~f:(fun self -> [ (elt_gen >>= fun head -> self >>= fun tail -> return (head :: tail)) ])) ;; let sexp_gen = (* Here we rely on [list_gen] to decrease the size of sub-elements, which also guarantees that the recursion will eventually bottom out. *) Generator.( fixed_point (fun self -> size >>= function | 0 -> String.quickcheck_generator >>| fun atom -> Sexp.Atom atom | _ -> list_gen self >>| fun list -> Sexp.List list)) ;; base_quickcheck-0.17.1/examples/recursive_types.ml000066400000000000000000000046251501616613400223210ustar00rootroot00000000000000open! Base open Base_quickcheck module _ : sig type t = | Leaf | Node of t * t [@@deriving quickcheck] end = struct type t = | Leaf | Node of t * t [@@deriving hash] let quickcheck_generator = let open Generator.Let_syntax in Generator.recursive_union [ Generator.return Leaf ] ~f:(fun self -> [ (let%map l = self and r = self in Node (l, r)) ]) ;; (* Observers can be derived from hash functions for most types. *) let quickcheck_observer = Observer.of_hash_fold hash_fold_t (* A good strategy for shrinking a recursive node is to try replacing the node with its recursive children, and also try pointwise-shrinking all fields of the node. *) let quickcheck_shrinker = let rec f = function | Leaf -> Sequence.empty | Node (l, r) -> Sequence.round_robin [ Sequence.singleton l ; Sequence.singleton r ; Sequence.map (f l) ~f:(fun l -> Node (l, r)) ; Sequence.map (f r) ~f:(fun r -> Node (l, r)) ] in Shrinker.create f ;; end module _ : sig type 'a t = Node of 'a * 'a t list [@@deriving quickcheck] end = struct type 'a t = Node of 'a * 'a t list let quickcheck_generator quickcheck_generator_key = (* In order to bound recursion depth, we rely on the fact that the [list] generator always generates elements at strictly smaller sizes than the list itself. *) Generator.fixed_point (fun quickcheck_generator -> [%quickcheck.generator: key * t list] |> Generator.map ~f:(fun (key, list) -> Node (key, list))) ;; let quickcheck_observer quickcheck_observer_key = (* For polymorphic types, we cannot directly derive an observer from a hash function. So we use [Observer.fixed_point] instead. *) Observer.fixed_point (fun quickcheck_observer -> [%quickcheck.observer: key * t list] |> Observer.unmap ~f:(fun (Node (key, list)) -> key, list)) ;; let quickcheck_shrinker quickcheck_shrinker_key = (* We can define a simple shrinker using [Shrinker.fixed_point]. It won't include the strategy above of replacing a recursive node with its children. *) Shrinker.fixed_point (fun quickcheck_shrinker -> [%quickcheck.shrinker: key * t list] |> Shrinker.map ~f:(fun (key, list) -> Node (key, list)) ~f_inverse:(fun (Node (key, list)) -> key, list)) ;; end base_quickcheck-0.17.1/examples/recursive_types.mli000066400000000000000000000000541501616613400224620ustar00rootroot00000000000000(*_ This signature is deliberately empty *) base_quickcheck-0.17.1/examples/shrinker_example.ml000066400000000000000000000051111501616613400224150ustar00rootroot00000000000000open Core module Shrinker = Quickcheck.Shrinker module Generator = Quickcheck.Generator module Sorted_list = struct type t = int list [@@deriving sexp] let of_list list = List.stable_sort ~compare:Int.compare list let to_list t = t let quickcheck_generator elt = let open Generator.Monad_infix in List.quickcheck_generator elt >>| of_list ;; let custom_int_shrinker = Shrinker.create (fun n -> if n = 0 then Sequence.empty else Sequence.singleton (n / 2)) ;; let quickcheck_shrinker = let list_shrinker = List.quickcheck_shrinker custom_int_shrinker in Shrinker.map list_shrinker ~f:of_list ~f_inverse:to_list ;; let invariant t = if List.is_sorted t ~compare:Int.compare then () else failwiths ~here:[%here] "sorted_list isn't sorted" t sexp_of_t ;; let invalid_merge t_a t_b = List.append t_a t_b let merge t_a t_b = List.merge t_a t_b ~compare:Int.compare end let%test_module "sorted list" = (module struct let sorted_list_tuple_gen = let int_gen = Int.gen_incl (-100) 100 in let sorted_list_gen = Sorted_list.quickcheck_generator int_gen in Generator.tuple2 sorted_list_gen sorted_list_gen ;; let sorted_list_tuple_shrinker = Shrinker.tuple2 Sorted_list.quickcheck_shrinker Sorted_list.quickcheck_shrinker ;; let test f (a, b) = f a b |> Sorted_list.invariant let sexp_of_sorted_list_tuple = [%sexp_of: Sorted_list.t * Sorted_list.t] let%test_unit "Invalid merge \"should\" produce a valid sorted list (without \ shrinking)" = let run () = Quickcheck.test ~sexp_of:sexp_of_sorted_list_tuple sorted_list_tuple_gen ~f:(test Sorted_list.invalid_merge) in (* Swap which line is commented below to see error message with shrinking. *) assert (does_raise run) ;; (* run () *) let%test_unit "Invalid merge \"should\" produce a valid sorted list (with shrinking)" = let run () = Quickcheck.test ~shrinker:sorted_list_tuple_shrinker ~sexp_of:sexp_of_sorted_list_tuple sorted_list_tuple_gen ~f:(test Sorted_list.invalid_merge) in (* Swap which line is commented below to see error message with shrinking. *) assert (does_raise run) ;; (* run () *) let%test_unit "Valid merge should produce a valid sorted list (with shrinking)" = Quickcheck.test ~shrinker:sorted_list_tuple_shrinker ~sexp_of:sexp_of_sorted_list_tuple sorted_list_tuple_gen ~f:(test Sorted_list.merge) ;; end) ;; base_quickcheck-0.17.1/ppx_quickcheck/000077500000000000000000000000001501616613400177105ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/README.md000066400000000000000000000070321501616613400211710ustar00rootroot00000000000000# ppx_quickcheck Generation of Base_quickcheck generators, observers, and shrinkers from types. Syntax ------- Type definitions: `[@@deriving quickcheck]` Expressions: `[%quickcheck.generator: TYPE]`, `[%quickcheck.observer: TYPE]`, and `[%quickcheck.shrinker: TYPE]`. Basic usage ----- We use `ppx_deriving`/`ppx_type_conv`, so type definitions are annotated this way: ```ocaml type a = b * c [@@deriving quickcheck] ``` This generates definitions for `quickcheck_generator_a`, `quickcheck_observer_a`, and `quickcheck_shrinker_a`. The generator definition is based on `quickcheck_generator_b` and `quickcheck_generator_c`; likewise for the observer and shrinker. Type `t` -------- Following Jane Street's naming conventions, we assume that a type named `t` is the main type in a module, and we omit the `_t` suffix for its generated definitions. ```ocaml type t = A.t * B.t [@@deriving quickcheck] ``` This generates definitions for `quickcheck_generator`, `quickcheck_observer`, and `quickcheck_shrinker`. The definitions are based on `A.quickcheck_generator`, `B.quickcheck_generator`, and so on. Signature --------- `type t [@@deriving quickcheck]` in a module signature adds `val quickcheck_generator : t Base_quickcheck.Generator.t`, `val quickcheck_observer : t Base_quickcheck.Observer.t`, and `val quickcheck_shrinker : t Base_quickcheck.Shrinker.t` to the module type. Deriving generators, observers, and shrinkers without a type definition ----------------------------------------------------------------------- Sometimes you just want to run Quickcheck without having to create a new type. You can create generators, observers, and shrinkers using `[%quickcheck.generator: ...]`, `[%quickcheck.observer: ...]`, and `[%quickcheck.shrinker: ...]`: ```ocaml let generator = [%quickcheck.generator: float * int * [`A | `B | `C]] let observer = [%quickcheck.observer: float * int * [`A | `B | `C]] let shrinker = [%quickcheck.shrinker: float * int * [`A | `B | `C]] ``` For maps, the syntax that works is `[%quickcheck.generator: bool Map.M(String).t]`. Attributes ---------- The `@quickcheck.generator` attribute overrides the distribution for a type. ```ocaml type ranking = { name : (string [@quickcheck.generator Generator.string_of Generator.char_alpha]) ; high_score : (int [@quickcheck.generator Generator.int_inclusive 0 999_999]) } [@@deriving quickcheck] ``` The `@quickcheck.weight` attribute overrides the weight with which a variant clause is chosen. The default weight for each clause is 1. ```ocaml type tree = | Leaf | Node1 of tree * int * tree [@quickcheck.weight 1. /. 2.] | Node2 of tree * int * tree * int * tree [@quickcheck.weight 1. /. 3.] [@@deriving quickcheck] ``` The `@quickcheck.do_not_generate` attribute leaves a variant out of the generator entirely. This is similar to `[@quickcheck.weight 0.]`, but it does not require generators for the variant arguments to exist. Observers and shrinkers are not altered by this attribute. ```ocaml type v = | A | B of Something_that_cannot_be_generated.t [@quickcheck.do_not_generate] [@@deriving quickcheck] ``` Escaping -------- The expression extensions allow custom generators, observers, and shrinkers beyond just the default for a given type. In place of any type, use `[%custom ...]` to fill in an arbitrary expression. ```ocaml let generator = [%quickcheck.generator: [%custom Generator.int_uniform] * char * string] let observer = [%quickcheck.observer: int * [%custom Observer.opaque] * string] let shrinker = [%quickcheck.shrinker: int * char * [%custom Shrinker.atomic]] ``` base_quickcheck-0.17.1/ppx_quickcheck/dune000066400000000000000000000000001501616613400205540ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/expander/000077500000000000000000000000001501616613400215165ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/expander/clause_syntax.ml000066400000000000000000000123371501616613400247400ustar00rootroot00000000000000open! Import include Clause_syntax_intf module Variant = struct type ast = constructor_declaration type t = { ast : ast ; position : int } let create_list list = List.mapi list ~f:(fun position ast -> let loc = ast.pcd_loc in match ast.pcd_res with | Some _ -> unsupported ~loc "GADT" | None -> { ast; position }) ;; let salt t = Some t.position let location t = t.ast.pcd_loc let weight_attribute = Attribute.declare "quickcheck.weight" Attribute.Context.constructor_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) ;; let do_not_generate_attribute = Attribute.declare "quickcheck.do_not_generate" Attribute.Context.constructor_declaration Ast_pattern.(pstr nil) () ;; let weight t = match Attribute.get do_not_generate_attribute t.ast with | Some () -> None | None -> Some (match Attribute.get weight_attribute t.ast with | Some expr -> expr | None -> efloat ~loc:{ (location t) with loc_ghost = true } "1.") ;; let core_type_list t = match t.ast.pcd_args with | Pcstr_tuple list -> list | Pcstr_record label_decl_list -> List.map label_decl_list ~f:(fun label_decl -> label_decl.pld_type) ;; let pattern t ~loc pat_list = let arg = match t.ast.pcd_args with | Pcstr_tuple _ -> (match pat_list with | [] -> None | [ pat ] -> Some pat | _ -> Some (ppat_tuple ~loc pat_list)) | Pcstr_record label_decl_list -> let alist = List.map2_exn label_decl_list pat_list ~f:(fun label_decl pat -> lident_loc label_decl.pld_name, pat) in Some (ppat_record ~loc alist Closed) in ppat_construct ~loc (lident_loc t.ast.pcd_name) arg ;; let expression t ~loc _ expr_list = let arg = match t.ast.pcd_args with | Pcstr_tuple _ -> (match expr_list with | [] -> None | [ expr ] -> Some expr | _ -> Some (pexp_tuple ~loc expr_list)) | Pcstr_record label_decl_list -> let alist = List.map2_exn label_decl_list expr_list ~f:(fun label_decl expr -> lident_loc label_decl.pld_name, expr) in Some (pexp_record ~loc alist None) in pexp_construct ~loc (lident_loc t.ast.pcd_name) arg ;; end module Polymorphic_variant = struct type ast = row_field type t = ast let create_list = Fn.id let salt t = match t.prf_desc with | Rtag (label, _, _) -> Some (Ocaml_common.Btype.hash_variant label.txt) | Rinherit _ -> None ;; let location t = t.prf_loc let weight_attribute = Attribute.declare "quickcheck.weight" Attribute.Context.rtag Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) ;; let do_not_generate_attribute = Attribute.declare "quickcheck.do_not_generate" Attribute.Context.rtag Ast_pattern.(pstr nil) () ;; let weight t = match Attribute.get do_not_generate_attribute t with | Some () -> None | None -> Some (match Attribute.get weight_attribute t with | Some expr -> expr | None -> efloat ~loc:{ (location t) with loc_ghost = true } "1.") ;; let core_type_list t = match t.prf_desc with | Rtag (_, _, core_type_list) -> core_type_list | Rinherit core_type -> [ core_type ] ;; let pattern t ~loc pat_list = match t.prf_desc, pat_list with | Rtag (label, true, []), [] -> ppat_variant ~loc label.txt None | Rtag (label, false, [ _ ]), [ pat ] -> ppat_variant ~loc label.txt (Some pat) | Rtag (label, false, [ _ ]), _ :: _ :: _ -> ppat_variant ~loc label.txt (Some (ppat_tuple ~loc pat_list)) | Rinherit { ptyp_desc; _ }, [ { ppat_desc; _ } ] -> (match ptyp_desc with | Ptyp_constr (id, _) -> (match ppat_desc with | Ppat_var var -> ppat_alias ~loc (ppat_type ~loc id) var | _ -> internal_error ~loc "cannot bind a # pattern to anything other than a variable") | _ -> unsupported ~loc "inherited polymorphic variant type that is not a type name") | Rtag (_, true, _ :: _), _ | Rtag (_, false, ([] | _ :: _ :: _)), _ -> unsupported ~loc "intersection type" | Rtag (_, true, []), _ :: _ | Rtag (_, false, [ _ ]), [] | Rinherit _, ([] | _ :: _ :: _) -> internal_error ~loc "wrong number of arguments for variant clause" ;; let expression t ~loc core_type expr_list = match t.prf_desc, expr_list with | Rtag (label, true, []), [] -> pexp_variant ~loc label.txt None | Rtag (label, false, [ _ ]), [ expr ] -> pexp_variant ~loc label.txt (Some expr) | Rtag (label, false, [ _ ]), _ :: _ :: _ -> pexp_variant ~loc label.txt (Some (pexp_tuple ~loc expr_list)) | Rinherit inherited_type, [ expr ] -> pexp_coerce ~loc expr (Some inherited_type) core_type | Rtag (_, true, _ :: _), _ | Rtag (_, false, ([] | _ :: _ :: _)), _ -> unsupported ~loc "intersection type" | Rtag (_, true, []), _ :: _ | Rtag (_, false, [ _ ]), [] | Rinherit _, ([] | _ :: _ :: _) -> internal_error ~loc "wrong number of arguments for variant clause" ;; end base_quickcheck-0.17.1/ppx_quickcheck/expander/clause_syntax.mli000066400000000000000000000000511501616613400250770ustar00rootroot00000000000000include Clause_syntax_intf.Clause_syntax base_quickcheck-0.17.1/ppx_quickcheck/expander/clause_syntax_intf.ml000066400000000000000000000021551501616613400257550ustar00rootroot00000000000000open! Import module type S = sig type ast type t val create_list : ast list -> t list (** Add to hash state via [hash_fold_int] to signify what clause we're in. [None] for inherited polymorphic variant clauses, since their observers will have salt for concrete tags. *) val salt : t -> int option (** location of the clause's definition *) val location : t -> location (** weight of the clause relative to other clauses in the generator distribution, or [None] if the clause should be excluded from the distribution *) val weight : t -> expression option (** types of the clause's arguments *) val core_type_list : t -> core_type list (** constructing a pattern to match the clause *) val pattern : t -> loc:location -> pattern list -> pattern (** constructing an expression to create an instance of the clause *) val expression : t -> loc:location -> core_type -> expression list -> expression end module type Clause_syntax = sig module type S = S module Variant : S with type ast = constructor_declaration module Polymorphic_variant : S with type ast = row_field end base_quickcheck-0.17.1/ppx_quickcheck/expander/dune000066400000000000000000000004241501616613400223740ustar00rootroot00000000000000(library (name ppx_quickcheck_expander) (public_name base_quickcheck.ppx_quickcheck.expander) (libraries base ppxlib ppxlib_jane compiler-libs.common) (ppx_runtime_libraries base_quickcheck.ppx_quickcheck.runtime base_quickcheck) (preprocess (pps ppxlib.metaquot))) base_quickcheck-0.17.1/ppx_quickcheck/expander/environment.ml000066400000000000000000000046261501616613400244240ustar00rootroot00000000000000open! Import type 'a or_raise = | Ok of 'a | Error of { fail : 'a. loc:location -> 'a } type t = (string, expression or_raise, String.comparator_witness) Map.t let empty = Map.empty (module String) let lookup t ~loc ~tyvar = match Map.find t tyvar with | Some (Ok expr) -> expr | Some (Error { fail }) -> fail ~loc | None -> invalid ~loc "unbound type variable: '%s" tyvar ;; let of_alist ~loc alist = match Map.of_alist (module String) alist with | `Ok t -> t | `Duplicate_key name -> invalid ~loc "duplicate type parameter: '%s" name ;; let create ~loc ~prefix param_list = let pat_list, alist = List.map param_list ~f:(fun ((core_type, _) as param) -> let loc = core_type.ptyp_loc in let name = get_type_param_name param in let pat, expr = gensym prefix loc in pat, (name.txt, Ok expr)) |> List.unzip in let t = of_alist ~loc alist in pat_list, t ;; let variance_error ~loc ~tyvar ~actual ~expect = invalid ~loc "misuse of type variable '%s: would confuse %s with %s in generated code; could be \ due to a missing or incorrect covariance/contravariance annotation" tyvar actual expect ;; let create_with_variance ~loc ~covariant ~contravariant param_list = let pat_list, by_variance_list = List.map param_list ~f:(fun ((core_type, (variance, _)) as param) -> let loc = core_type.ptyp_loc in let name = get_type_param_name param in match variance with | NoVariance | Covariant -> let pat, expr = gensym covariant loc in pat, `Covariant (name.txt, expr) | Contravariant -> let pat, expr = gensym contravariant loc in pat, `Contravariant (name.txt, expr)) |> List.unzip in let covariant_t = List.map by_variance_list ~f:(function | `Covariant (tyvar, expr) -> tyvar, Ok expr | `Contravariant (tyvar, _) -> let fail ~loc = variance_error ~loc ~tyvar ~expect:covariant ~actual:contravariant in tyvar, Error { fail }) |> of_alist ~loc in let contravariant_t = List.map by_variance_list ~f:(function | `Contravariant (tyvar, expr) -> tyvar, Ok expr | `Covariant (tyvar, _) -> let fail ~loc = variance_error ~loc ~tyvar ~expect:contravariant ~actual:covariant in tyvar, Error { fail }) |> of_alist ~loc in pat_list, `Covariant covariant_t, `Contravariant contravariant_t ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/environment.mli000066400000000000000000000013371501616613400245710ustar00rootroot00000000000000open! Import (** Maps type variables to patterns and expressions for gensym'd variables. Used to handle type parameters in polymorphic type definitions. *) type t val empty : t val lookup : t -> loc:location -> tyvar:string -> expression val create : loc:location -> prefix:string -> (core_type * (variance * injectivity)) list -> pattern list * t (** For generators, we want contravariant type parameters to map to observer names. For observers, vice versa. So we create both environment simultaneously. *) val create_with_variance : loc:location -> covariant:string -> contravariant:string -> (core_type * (variance * injectivity)) list -> pattern list * [ `Covariant of t ] * [ `Contravariant of t ] base_quickcheck-0.17.1/ppx_quickcheck/expander/field_syntax.ml000066400000000000000000000026061501616613400245450ustar00rootroot00000000000000open! Import include Field_syntax_intf module Tuple = struct type ast = core_type type t = ast let create = Fn.id let location t = t.ptyp_loc let core_type t = t let pattern _ ~loc pat_list = ppat_tuple ~loc pat_list let expression _ ~loc expr_list = pexp_tuple ~loc expr_list end module Labeled_tuple = struct type ast = string option * core_type type t = ast let create = Fn.id let location (_, t) = t.ptyp_loc let core_type (_, t) = t let pattern list ~loc pat_list = let alist = List.map2_exn list pat_list ~f:(fun (label, _) pat -> label, pat) in Ppxlib_jane.Jane_syntax.Pattern.pat_of ~loc ~attrs:[] (Jpat_tuple (alist, Closed)) ;; let expression list ~loc expr_list = let alist = List.map2_exn list expr_list ~f:(fun (label, _) expr -> label, expr) in Ppxlib_jane.Jane_syntax.Expression.expr_of ~loc ~attrs:[] (Jexp_tuple alist) ;; end module Record = struct type ast = label_declaration type t = ast let create ast = ast let location t = t.pld_loc let core_type t = t.pld_type let pattern list ~loc pat_list = let alist = List.map2_exn list pat_list ~f:(fun t pat -> lident_loc t.pld_name, pat) in ppat_record ~loc alist Closed ;; let expression list ~loc expr_list = let alist = List.map2_exn list expr_list ~f:(fun t expr -> lident_loc t.pld_name, expr) in pexp_record ~loc alist None ;; end base_quickcheck-0.17.1/ppx_quickcheck/expander/field_syntax.mli000066400000000000000000000000471501616613400247130ustar00rootroot00000000000000include Field_syntax_intf.Field_syntax base_quickcheck-0.17.1/ppx_quickcheck/expander/field_syntax_intf.ml000066400000000000000000000013341501616613400255620ustar00rootroot00000000000000open! Import module type S = sig type ast type t val create : ast -> t (** location of the field declaration *) val location : t -> location (** type of the field's contents *) val core_type : t -> core_type (** constructing a pattern to match all fields of the type *) val pattern : t list -> loc:location -> pattern list -> pattern (** constructing an expression filling in all fields of the type *) val expression : t list -> loc:location -> expression list -> expression end module type Field_syntax = sig module type S = S module Tuple : S with type ast = core_type module Labeled_tuple : S with type ast = string option * core_type module Record : S with type ast = label_declaration end base_quickcheck-0.17.1/ppx_quickcheck/expander/import.ml000066400000000000000000000051461501616613400233700ustar00rootroot00000000000000include Base include Ppxlib include Ast_builder.Default (* errors and error messages *) let ( ^^ ) = Stdlib.( ^^ ) let error ~loc fmt = Location.raise_errorf ~loc ("ppx_quickcheck: " ^^ fmt) let invalid ~loc fmt = error ~loc ("invalid syntax: " ^^ fmt) let unsupported ~loc fmt = error ~loc ("unsupported: " ^^ fmt) let internal_error ~loc fmt = error ~loc ("internal error: " ^^ fmt) let short_string_of_core_type core_type = match core_type.ptyp_desc with | Ptyp_any -> "wildcard type" | Ptyp_var _ -> "type variable" | Ptyp_arrow _ -> "function type" | Ptyp_tuple _ -> "tuple type" | Ptyp_constr _ -> "type name" | Ptyp_object _ -> "object type" | Ptyp_class _ -> "class type" | Ptyp_alias _ -> "type variable alias" | Ptyp_variant _ -> "polymorphic variant" | Ptyp_poly _ -> "explicit polymorphic type" | Ptyp_package _ -> "first-class module type" | Ptyp_extension _ -> "ppx extension type" | Ptyp_open _ -> "local module open" ;; (* little syntax helpers *) let loc_map { loc; txt } ~f = { loc; txt = f txt } let lident_loc = loc_map ~f:lident let prefixed_type_name prefix type_name = match type_name with | "t" -> prefix | _ -> prefix ^ "_" ^ type_name ;; let generator_name type_name = prefixed_type_name "quickcheck_generator" type_name let observer_name type_name = prefixed_type_name "quickcheck_observer" type_name let shrinker_name type_name = prefixed_type_name "quickcheck_shrinker" type_name let pname { loc; txt } ~f = pvar ~loc (f txt) let ename { loc; txt } ~f = evar ~loc (f txt) let pgenerator = pname ~f:generator_name let pobserver = pname ~f:observer_name let pshrinker = pname ~f:shrinker_name let egenerator = ename ~f:generator_name let eobserver = ename ~f:observer_name let eshrinker = ename ~f:shrinker_name let ptuple ~loc list = match list with | [] -> [%pat? ()] | [ pat ] -> pat | _ -> ppat_tuple ~loc list ;; (* creating (probably-)unique symbols for generated code *) let gensym prefix loc = let loc = { loc with loc_ghost = true } in let sym = gen_symbol ~prefix:("_" ^ prefix) () in pvar ~loc sym, evar ~loc sym ;; let gensyms prefix loc_list = List.map loc_list ~f:(gensym prefix) |> List.unzip let gensymss prefix loc_list_list = List.map loc_list_list ~f:(gensyms prefix) |> List.unzip ;; (* expression to create a higher order function that maps from function with one kind of argument label to another *) let fn_map_label ~loc ~from ~to_ = let f_pat, f_expr = gensym "f" loc in let x_pat, x_expr = gensym "x" loc in pexp_fun ~loc Nolabel None f_pat (pexp_fun ~loc to_ None x_pat (pexp_apply ~loc f_expr [ from, x_expr ])) ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_generator_expander.ml000066400000000000000000000135421501616613400266200ustar00rootroot00000000000000open! Import let arrow ~generator_of_core_type ~observer_of_core_type ~loc ~arg_label ~input_type ~output_type = let input_observer = match arg_label with | Nolabel | Labelled _ -> observer_of_core_type input_type | Optional _ -> [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.option [%e observer_of_core_type input_type]] in let output_generator = generator_of_core_type output_type in let unlabelled = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.fn [%e input_observer] [%e output_generator]] in match arg_label with | Nolabel -> unlabelled | Labelled _ | Optional _ -> [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.map ~f:[%e fn_map_label ~loc ~from:Nolabel ~to_:arg_label] [%e unlabelled]] ;; let compound_generator ~loc ~make_compound_expr generator_list = let loc = { loc with loc_ghost = true } in let size_pat, size_expr = gensym "size" loc in let random_pat, random_expr = gensym "random" loc in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.create (fun ~size:[%p size_pat] ~random:[%p random_pat] -> [%e make_compound_expr ~loc (List.map generator_list ~f:(fun generator -> let loc = { generator.pexp_loc with loc_ghost = true } in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.generate [%e generator] ~size:[%e size_expr] ~random:[%e random_expr]]))])] ;; let compound (type field) ~generator_of_core_type ~loc ~fields (module Field : Field_syntax.S with type ast = field) = let fields = List.map fields ~f:Field.create in compound_generator ~loc ~make_compound_expr:(Field.expression fields) (List.map fields ~f:(fun field -> generator_of_core_type (Field.core_type field))) ;; let does_refer_to name_set = object (self) inherit [bool] Ast_traverse.fold as super method! core_type ty acc = match ty.ptyp_desc with | Ptyp_constr (name, args) -> acc || Set.mem name_set (Longident.name name.txt) || List.exists args ~f:(fun arg -> self#core_type arg false) | _ -> super#core_type ty acc end ;; let clause_is_recursive (type clause) ~clause ~rec_names (module Clause : Clause_syntax.S with type t = clause) = List.exists (Clause.core_type_list clause) ~f:(fun ty -> (does_refer_to rec_names)#core_type ty false) ;; let variant (type clause) ~generator_of_core_type ~loc ~variant_type ~clauses ~rec_names (module Clause : Clause_syntax.S with type ast = clause) = let clauses = Clause.create_list clauses in let make_generator clause = compound_generator ~loc:(Clause.location clause) ~make_compound_expr:(Clause.expression clause variant_type) (List.map (Clause.core_type_list clause) ~f:generator_of_core_type) in let make_pair clause = Option.map (Clause.weight clause) ~f:(fun weight -> pexp_tuple ~loc:{ (Clause.location clause) with loc_ghost = true } [ weight; make_generator clause ]) in (* We filter out clauses with weight None now. If we don't, then we can get code in [body] below that relies on bindings that don't get generated. *) let clauses = List.filter clauses ~f:(fun clause -> Option.is_some (Clause.weight clause)) in match List.partition_tf clauses ~f:(fun clause -> clause_is_recursive ~clause ~rec_names (module Clause)) with | [], [] -> invalid ~loc "variant had no (generated) cases" | [], clauses | clauses, [] -> let pairs = List.filter_map clauses ~f:make_pair in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.weighted_union [%e elist ~loc pairs]] | recursive_clauses, nonrecursive_clauses -> let size_pat, size_expr = gensym "size" loc in let nonrec_pat, nonrec_expr = gensym "gen" loc in let rec_pat, rec_expr = gensym "gen" loc in let nonrec_pats, nonrec_exprs = gensyms "pair" (List.map nonrecursive_clauses ~f:Clause.location) in let rec_pats, rec_exprs = gensyms "pair" (List.map recursive_clauses ~f:Clause.location) in let bindings = List.filter_opt (List.map2_exn nonrec_pats nonrecursive_clauses ~f:(fun pat clause -> let loc = { (Clause.location clause) with loc_ghost = true } in Option.map (make_pair clause) ~f:(fun expr -> value_binding ~loc ~pat ~expr)) @ List.map2_exn rec_pats recursive_clauses ~f:(fun pat clause -> Option.map (Clause.weight clause) ~f:(fun weight_expr -> let loc = { (Clause.location clause) with loc_ghost = true } in let gen_expr = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.bind Ppx_quickcheck_runtime.Base_quickcheck.Generator.size ~f:(fun [%p size_pat] -> Ppx_quickcheck_runtime.Base_quickcheck.Generator.with_size ~size:(Ppx_quickcheck_runtime.Base.Int.pred [%e size_expr]) [%e make_generator clause])] in let expr = pexp_tuple ~loc [ weight_expr; gen_expr ] in value_binding ~loc ~pat ~expr))) in let body = [%expr let [%p nonrec_pat] = Ppx_quickcheck_runtime.Base_quickcheck.Generator.weighted_union [%e elist ~loc nonrec_exprs] and [%p rec_pat] = Ppx_quickcheck_runtime.Base_quickcheck.Generator.weighted_union [%e elist ~loc (nonrec_exprs @ rec_exprs)] in Ppx_quickcheck_runtime.Base_quickcheck.Generator.bind Ppx_quickcheck_runtime.Base_quickcheck.Generator.size ~f:(function | 0 -> [%e nonrec_expr] | _ -> [%e rec_expr])] in pexp_let ~loc Nonrecursive bindings body ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_generator_expander.mli000066400000000000000000000012351501616613400267650ustar00rootroot00000000000000open! Import val compound : generator_of_core_type:(core_type -> expression) -> loc:location -> fields:'a list -> (module Field_syntax.S with type ast = 'a) -> expression val variant : generator_of_core_type:(core_type -> expression) -> loc:location -> variant_type:core_type -> clauses:'a list -> rec_names:(string, String.comparator_witness) Set.t -> (module Clause_syntax.S with type ast = 'a) -> expression val arrow : generator_of_core_type:(core_type -> expression) -> observer_of_core_type:(core_type -> expression) -> loc:location -> arg_label:arg_label -> input_type:core_type -> output_type:core_type -> expression base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_observer_expander.ml000066400000000000000000000077621501616613400264700ustar00rootroot00000000000000open! Import let any ~loc = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.opaque] let arrow ~observer_of_core_type ~generator_of_core_type ~loc ~arg_label ~input_type ~output_type = let input_generator = match arg_label with | Nolabel | Labelled _ -> generator_of_core_type input_type | Optional _ -> [%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.option [%e generator_of_core_type input_type]] in let output_observer = observer_of_core_type output_type in let unlabelled = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.fn [%e input_generator] [%e output_observer]] in match arg_label with | Nolabel -> unlabelled | Labelled _ | Optional _ -> [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.unmap ~f:[%e fn_map_label ~loc ~from:arg_label ~to_:Nolabel] [%e unlabelled]] ;; let compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs = let alist = List.zip_exn observer_exprs field_exprs in List.fold_right alist ~init:hash_expr ~f:(fun (observer_expr, field_expr) body_expr -> [%expr let [%p hash_pat] = Ppx_quickcheck_runtime.Base_quickcheck.Observer.observe [%e observer_expr] [%e field_expr] ~size:[%e size_expr] ~hash:[%e hash_expr] in [%e body_expr]]) ;; let compound (type field) ~observer_of_core_type ~loc ~fields (module Field : Field_syntax.S with type ast = field) = let pat, exp = gensym "x" loc in let fields = List.map fields ~f:Field.create in let field_pats, field_exprs = gensyms "x" (List.map fields ~f:Field.location) in let record_pat = Field.pattern fields ~loc field_pats in let observer_exprs = List.map fields ~f:(fun field -> observer_of_core_type (Field.core_type field)) in let size_pat, size_expr = gensym "size" loc in let hash_pat, hash_expr = gensym "hash" loc in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.create (fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] -> let [%p record_pat] = [%e exp] in [%e compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs])] ;; let variant (type clause) ~observer_of_core_type ~loc ~clauses (module Clause : Clause_syntax.S with type ast = clause) = let clauses = Clause.create_list clauses in let pat, expr = gensym "x" loc in let size_pat, size_expr = gensym "size" loc in let hash_pat, hash_expr = gensym "hash" loc in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.create (fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] -> [%e pexp_match ~loc expr (List.map clauses ~f:(fun clause -> let core_type_list = Clause.core_type_list clause in let observer_exprs = List.map core_type_list ~f:observer_of_core_type in let field_pats, field_exprs = gensyms "x" (List.map core_type_list ~f:(fun core_type -> core_type.ptyp_loc)) in let lhs = Clause.pattern clause ~loc field_pats in let body = compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs in let rhs = match Clause.salt clause with | None -> body | Some salt -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:hash_pat ~expr: [%expr Ppx_quickcheck_runtime.Base.hash_fold_int [%e hash_expr] [%e eint ~loc salt]] ] body in case ~lhs ~guard:None ~rhs))])] ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_observer_expander.mli000066400000000000000000000011541501616613400266260ustar00rootroot00000000000000open! Import val any : loc:location -> expression val compound : observer_of_core_type:(core_type -> expression) -> loc:location -> fields:'a list -> (module Field_syntax.S with type ast = 'a) -> expression val variant : observer_of_core_type:(core_type -> expression) -> loc:location -> clauses:'a list -> (module Clause_syntax.S with type ast = 'a) -> expression val arrow : observer_of_core_type:(core_type -> expression) -> generator_of_core_type:(core_type -> expression) -> loc:location -> arg_label:arg_label -> input_type:core_type -> output_type:core_type -> expression base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_quickcheck_expander.ml000066400000000000000000000450511501616613400267440ustar00rootroot00000000000000open! Import let custom_extension ~loc tag payload = match String.equal tag.txt "custom" with | false -> unsupported ~loc "unknown extension: %s" tag.txt | true -> (match payload with | PStr [ { pstr_desc = Pstr_eval (expr, attributes); _ } ] -> assert_no_attributes attributes; expr | _ -> invalid ~loc "[%%custom] extension expects a single expression as its payload") ;; let generator_attribute = Attribute.declare "quickcheck.generator" Attribute.Context.core_type Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) ;; let rec generator_of_core_type core_type ~gen_env ~obs_env = let loc = { core_type.ptyp_loc with loc_ghost = true } in match Attribute.get generator_attribute core_type with | Some expr -> expr | None -> (match Ppxlib_jane.Jane_syntax.Core_type.of_ast core_type with | Some (Jtyp_tuple fields, _attrs) -> Ppx_generator_expander.compound ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~loc ~fields (module Field_syntax.Labeled_tuple) | Some (Jtyp_layout _, _) | None -> (match core_type.ptyp_desc with | Ptyp_constr (constr, args) -> type_constr_conv ~loc ~f:generator_name constr (List.map args ~f:(generator_of_core_type ~gen_env ~obs_env)) | Ptyp_var tyvar -> Environment.lookup gen_env ~loc ~tyvar | Ptyp_arrow (arg_label, input_type, output_type) -> Ppx_generator_expander.arrow ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~observer_of_core_type:(observer_of_core_type ~gen_env ~obs_env) ~loc ~arg_label ~input_type ~output_type | Ptyp_tuple fields -> Ppx_generator_expander.compound ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~loc ~fields (module Field_syntax.Tuple) | Ptyp_variant (clauses, Closed, None) -> Ppx_generator_expander.variant ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~loc ~variant_type:core_type ~clauses ~rec_names:(Set.empty (module String)) (module Clause_syntax.Polymorphic_variant) | Ptyp_variant (_, Open, _) -> unsupported ~loc "polymorphic variant type with [>]" | Ptyp_variant (_, _, Some _) -> unsupported ~loc "polymorphic variant type with [<]" | Ptyp_extension (tag, payload) -> custom_extension ~loc tag payload | Ptyp_any | Ptyp_object _ | Ptyp_class _ | Ptyp_alias _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_open _ -> unsupported ~loc "%s" (short_string_of_core_type core_type))) and observer_of_core_type core_type ~obs_env ~gen_env = let loc = { core_type.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast core_type with | Some (Jtyp_tuple fields, _attrs) -> Ppx_observer_expander.compound ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~loc ~fields (module Field_syntax.Labeled_tuple) | Some (Jtyp_layout _, _) | None -> (match core_type.ptyp_desc with | Ptyp_constr (constr, args) -> type_constr_conv ~loc ~f:observer_name constr (List.map args ~f:(observer_of_core_type ~obs_env ~gen_env)) | Ptyp_var tyvar -> Environment.lookup obs_env ~loc ~tyvar | Ptyp_arrow (arg_label, input_type, output_type) -> Ppx_observer_expander.arrow ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~generator_of_core_type:(generator_of_core_type ~obs_env ~gen_env) ~loc ~arg_label ~input_type ~output_type | Ptyp_tuple fields -> Ppx_observer_expander.compound ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~loc ~fields (module Field_syntax.Tuple) | Ptyp_variant (clauses, Closed, None) -> Ppx_observer_expander.variant ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~loc ~clauses (module Clause_syntax.Polymorphic_variant) | Ptyp_variant (_, Open, _) -> unsupported ~loc "polymorphic variant type with [>]" | Ptyp_variant (_, _, Some _) -> unsupported ~loc "polymorphic variant type with [<]" | Ptyp_extension (tag, payload) -> custom_extension ~loc tag payload | Ptyp_any -> Ppx_observer_expander.any ~loc | Ptyp_object _ | Ptyp_class _ | Ptyp_alias _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_open _ -> unsupported ~loc "%s" (short_string_of_core_type core_type)) ;; let rec shrinker_of_core_type core_type ~env = let loc = { core_type.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast core_type with | Some (Jtyp_tuple fields, _attrs) -> Ppx_shrinker_expander.compound ~shrinker_of_core_type:(shrinker_of_core_type ~env) ~loc ~fields (module Field_syntax.Labeled_tuple) | Some (Jtyp_layout _, _) | None -> (match core_type.ptyp_desc with | Ptyp_constr (constr, args) -> type_constr_conv ~loc ~f:shrinker_name constr (List.map args ~f:(shrinker_of_core_type ~env)) | Ptyp_var tyvar -> Environment.lookup env ~loc ~tyvar | Ptyp_arrow _ -> Ppx_shrinker_expander.arrow ~loc | Ptyp_tuple fields -> Ppx_shrinker_expander.compound ~shrinker_of_core_type:(shrinker_of_core_type ~env) ~loc ~fields (module Field_syntax.Tuple) | Ptyp_variant (clauses, Closed, None) -> Ppx_shrinker_expander.variant ~shrinker_of_core_type:(shrinker_of_core_type ~env) ~loc ~variant_type:core_type ~clauses (module Clause_syntax.Polymorphic_variant) | Ptyp_variant (_, Open, _) -> unsupported ~loc "polymorphic variant type with [>]" | Ptyp_variant (_, _, Some _) -> unsupported ~loc "polymorphic variant type with [<]" | Ptyp_extension (tag, payload) -> custom_extension ~loc tag payload | Ptyp_any -> Ppx_shrinker_expander.any ~loc | Ptyp_object _ | Ptyp_class _ | Ptyp_alias _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_open _ -> unsupported ~loc "%s" (short_string_of_core_type core_type)) ;; type impl = { loc : location ; typ : core_type ; pat : pattern ; var : expression ; exp : expression } let generator_impl type_decl ~rec_names = let loc = type_decl.ptype_loc in let typ = combinator_type_of_type_declaration type_decl ~f:(fun ~loc ty -> [%type: [%t ty] Ppx_quickcheck_runtime.Base_quickcheck.Generator.t]) in let pat = pgenerator type_decl.ptype_name in let var = egenerator type_decl.ptype_name in let exp = let pat_list, `Covariant gen_env, `Contravariant obs_env = Environment.create_with_variance ~loc ~covariant:"generator" ~contravariant:"observer" type_decl.ptype_params in let body = match type_decl.ptype_kind with | Ptype_open -> unsupported ~loc "open type" | Ptype_variant clauses -> Ppx_generator_expander.variant ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~loc ~variant_type:[%type: _] ~clauses ~rec_names (module Clause_syntax.Variant) | Ptype_record fields -> Ppx_generator_expander.compound ~generator_of_core_type:(generator_of_core_type ~gen_env ~obs_env) ~loc ~fields (module Field_syntax.Record) | Ptype_abstract -> (match type_decl.ptype_manifest with | Some core_type -> generator_of_core_type core_type ~gen_env ~obs_env | None -> unsupported ~loc "abstract type") in List.fold_right pat_list ~init:body ~f:(fun pat body -> [%expr fun [%p pat] -> [%e body]]) in { loc; typ; pat; var; exp } ;; let observer_impl type_decl ~rec_names:_ = let loc = type_decl.ptype_loc in let typ = combinator_type_of_type_declaration type_decl ~f:(fun ~loc ty -> [%type: [%t ty] Ppx_quickcheck_runtime.Base_quickcheck.Observer.t]) in let pat = pobserver type_decl.ptype_name in let var = eobserver type_decl.ptype_name in let exp = let pat_list, `Covariant obs_env, `Contravariant gen_env = Environment.create_with_variance ~loc ~covariant:"observer" ~contravariant:"generator" type_decl.ptype_params in let body = match type_decl.ptype_kind with | Ptype_open -> unsupported ~loc "open type" | Ptype_variant clauses -> Ppx_observer_expander.variant ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~loc ~clauses (module Clause_syntax.Variant) | Ptype_record fields -> Ppx_observer_expander.compound ~observer_of_core_type:(observer_of_core_type ~obs_env ~gen_env) ~loc ~fields (module Field_syntax.Record) | Ptype_abstract -> (match type_decl.ptype_manifest with | Some core_type -> observer_of_core_type core_type ~obs_env ~gen_env | None -> unsupported ~loc "abstract type") in List.fold_right pat_list ~init:body ~f:(fun pat body -> [%expr fun [%p pat] -> [%e body]]) in { loc; typ; pat; var; exp } ;; let shrinker_impl type_decl ~rec_names:_ = let loc = type_decl.ptype_loc in let typ = combinator_type_of_type_declaration type_decl ~f:(fun ~loc ty -> [%type: [%t ty] Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t]) in let pat = pshrinker type_decl.ptype_name in let var = eshrinker type_decl.ptype_name in let exp = let pat_list, env = Environment.create ~loc ~prefix:"shrinker" type_decl.ptype_params in let body = match type_decl.ptype_kind with | Ptype_open -> unsupported ~loc "open type" | Ptype_variant clauses -> Ppx_shrinker_expander.variant ~shrinker_of_core_type:(shrinker_of_core_type ~env) ~loc ~variant_type:[%type: _] ~clauses (module Clause_syntax.Variant) | Ptype_record fields -> Ppx_shrinker_expander.compound ~shrinker_of_core_type:(shrinker_of_core_type ~env) ~loc ~fields (module Field_syntax.Record) | Ptype_abstract -> (match type_decl.ptype_manifest with | Some core_type -> shrinker_of_core_type core_type ~env | None -> unsupported ~loc "abstract type") in List.fold_right pat_list ~init:body ~f:(fun pat body -> [%expr fun [%p pat] -> [%e body]]) in { loc; typ; pat; var; exp } ;; let close_the_loop ~of_lazy decl impl = let loc = impl.loc in let exp = impl.var in match decl.ptype_params with | [] -> eapply ~loc of_lazy [ exp ] | params -> let pats, exps = gensyms "recur" (List.map params ~f:(fun (core_type, _) -> core_type.ptyp_loc)) in eabstract ~loc pats (eapply ~loc of_lazy [ [%expr lazy [%e eapply ~loc (eapply ~loc [%expr Ppx_quickcheck_runtime.Base.Lazy.force] [ exp ]) exps]] ]) ;; let maybe_mutually_recursive decls ~loc ~rec_flag ~of_lazy ~impl = let decls = List.map decls ~f:name_type_params_in_td in let rec_names = match rec_flag with | Nonrecursive -> Set.empty (module String) | Recursive -> Set.of_list (module String) (List.map decls ~f:(fun decl -> decl.ptype_name.txt)) in let impls = List.map decls ~f:(fun decl -> impl decl ~rec_names) in match rec_flag with | Nonrecursive -> pstr_value_list ~loc Nonrecursive (List.map impls ~f:(fun impl -> value_binding ~loc:impl.loc ~pat:impl.pat ~expr:impl.exp)) | Recursive -> let recursive_bindings = let inner_bindings = List.map2_exn decls impls ~f:(fun decl inner -> value_binding ~loc:inner.loc ~pat:inner.pat ~expr:(close_the_loop ~of_lazy decl inner)) in let rec wrap exp = match exp.pexp_desc with | Pexp_function (params, constr, Pfunction_body body) -> { exp with pexp_desc = Pexp_function (params, constr, Pfunction_body (wrap body)) } | _ -> List.fold impls ~init:exp ~f:(fun acc impl -> let ign = [%expr ignore [%e impl.var]] in pexp_sequence ~loc ign acc) |> pexp_let ~loc Nonrecursive inner_bindings in List.map2_exn decls impls ~f:(fun decl impl -> let body = wrap impl.exp in let lazy_expr = [%expr lazy [%e body]] in let typed_pat = [%type: [%t impl.typ] Ppx_quickcheck_runtime.Base.Lazy.t] |> ptyp_poly ~loc (List.map decl.ptype_params ~f:get_type_param_name) |> ppat_constraint ~loc impl.pat in value_binding ~loc:impl.loc ~pat:typed_pat ~expr:lazy_expr) in [%str include struct open [%m pmod_structure ~loc (pstr_value_list ~loc Recursive recursive_bindings)] [%%i pstr_value ~loc Nonrecursive (List.map2_exn decls impls ~f:(fun decl impl -> value_binding ~loc ~pat:impl.pat ~expr:(close_the_loop ~of_lazy decl impl)))] end] ;; let generator_impl_list decls ~loc ~rec_flag = maybe_mutually_recursive decls ~loc ~rec_flag ~of_lazy:[%expr Ppx_quickcheck_runtime.Base_quickcheck.Generator.of_lazy] ~impl:generator_impl ;; let observer_impl_list decls ~loc ~rec_flag = maybe_mutually_recursive decls ~loc ~rec_flag ~of_lazy:[%expr Ppx_quickcheck_runtime.Base_quickcheck.Observer.of_lazy] ~impl:observer_impl ;; let shrinker_impl_list decls ~loc ~rec_flag = maybe_mutually_recursive decls ~loc ~rec_flag ~of_lazy:[%expr Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.of_lazy] ~impl:shrinker_impl ;; let intf type_decl ~f ~covar ~contravar = let covar = Longident.parse ("Ppx_quickcheck_runtime.Base_quickcheck." ^ covar ^ ".t") in let contravar = Longident.parse ("Ppx_quickcheck_runtime.Base_quickcheck." ^ contravar ^ ".t") in let type_decl = name_type_params_in_td type_decl in let loc = type_decl.ptype_loc in let name = loc_map type_decl.ptype_name ~f in let result = ptyp_constr ~loc { loc; txt = covar } [ ptyp_constr ~loc (lident_loc type_decl.ptype_name) (List.map type_decl.ptype_params ~f:fst) ] in let type_ = List.fold_right type_decl.ptype_params ~init:result ~f:(fun (core_type, (variance, _)) result -> let id = match variance with | NoVariance | Covariant -> covar | Contravariant -> contravar in let arg = ptyp_constr ~loc { loc; txt = id } [ core_type ] in [%type: [%t arg] -> [%t result]]) in psig_value ~loc (value_description ~loc ~name ~type_ ~prim:[]) ;; let shrinker_intf = intf ~f:shrinker_name ~covar:"Shrinker" ~contravar:"Shrinker" let generator_intf = intf ~f:generator_name ~covar:"Generator" ~contravar:"Observer" let observer_intf = intf ~f:observer_name ~covar:"Observer" ~contravar:"Generator" let generator_intf_list type_decl_list = List.map type_decl_list ~f:generator_intf let observer_intf_list type_decl_list = List.map type_decl_list ~f:observer_intf let shrinker_intf_list type_decl_list = List.map type_decl_list ~f:shrinker_intf let try_include_decl type_decl_list ~loc ~incl_generator ~incl_observer ~incl_shrinker = match type_decl_list with | [ type_decl ] -> let has_contravariant_arg = List.exists type_decl.ptype_params ~f:(fun (_type, (variance, _inj)) -> match variance with | Contravariant -> true | NoVariance | Covariant -> false) in if has_contravariant_arg || not (incl_generator && incl_observer && incl_shrinker) then None else ( let sg_name = "Ppx_quickcheck_runtime.Quickcheckable.S" in mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant:true type_decl_list |> Option.map ~f:(fun include_info -> psig_include ~loc include_info)) | _ -> (* Don't bother testing anything since [mk_named_sig] will definitely return [None] anyway *) None ;; let args () = Deriving.Args.(empty +> flag "generator" +> flag "observer" +> flag "shrinker") ;; let flags ~incl_generator ~incl_observer ~incl_shrinker = if not (incl_generator || incl_observer || incl_shrinker) then (* If no flags are provided, include everything. *) true, true, true else incl_generator, incl_observer, incl_shrinker ;; let create ~incl_generator ~incl_observer ~incl_shrinker ~make_generator_list ~make_observer_list ~make_shrinker_list decls = List.concat [ (if incl_generator then make_generator_list decls else []) ; (if incl_observer then make_observer_list decls else []) ; (if incl_shrinker then make_shrinker_list decls else []) ] ;; let sig_type_decl = Deriving.Generator.make (args ()) (fun ~loc ~path:_ (_, decls) incl_generator incl_observer incl_shrinker -> let incl_generator, incl_observer, incl_shrinker = flags ~incl_generator ~incl_observer ~incl_shrinker in match try_include_decl ~loc ~incl_generator ~incl_observer ~incl_shrinker decls with | Some decl -> [ decl ] | None -> create ~incl_generator ~incl_observer ~incl_shrinker ~make_generator_list:generator_intf_list ~make_observer_list:observer_intf_list ~make_shrinker_list:shrinker_intf_list decls) ;; let str_type_decl = Deriving.Generator.make (args ()) (fun ~loc ~path:_ (rec_flag, decls) incl_generator incl_observer incl_shrinker -> let rec_flag = really_recursive rec_flag decls in let incl_generator, incl_observer, incl_shrinker = flags ~incl_generator ~incl_observer ~incl_shrinker in create ~incl_generator ~incl_observer ~incl_shrinker ~make_generator_list:(generator_impl_list ~rec_flag ~loc) ~make_observer_list:(observer_impl_list ~rec_flag ~loc) ~make_shrinker_list:(shrinker_impl_list ~rec_flag ~loc) decls) ;; let generator_extension ~loc:_ ~path:_ core_type = generator_of_core_type core_type ~gen_env:Environment.empty ~obs_env:Environment.empty ;; let observer_extension ~loc:_ ~path:_ core_type = observer_of_core_type core_type ~obs_env:Environment.empty ~gen_env:Environment.empty ;; let shrinker_extension ~loc:_ ~path:_ core_type = shrinker_of_core_type core_type ~env:Environment.empty ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_quickcheck_expander.mli000066400000000000000000000006551501616613400271160ustar00rootroot00000000000000open! Import val sig_type_decl : (signature, rec_flag * type_declaration list) Deriving.Generator.t val str_type_decl : (structure, rec_flag * type_declaration list) Deriving.Generator.t val generator_extension : loc:location -> path:string -> core_type -> expression val observer_extension : loc:location -> path:string -> core_type -> expression val shrinker_extension : loc:location -> path:string -> core_type -> expression base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_shrinker_expander.ml000066400000000000000000000052651501616613400264620ustar00rootroot00000000000000open! Import let any ~loc = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.atomic] let arrow ~loc = [%expr Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.atomic] let compound_sequence ~loc ~make_compound_expr ~field_pats ~field_exprs ~shrinker_exprs = [%expr Ppx_quickcheck_runtime.Base.Sequence.round_robin [%e elist ~loc (List.map3_exn field_pats field_exprs shrinker_exprs ~f:(fun field_pat field_expr shrinker -> let loc = { shrinker.pexp_loc with loc_ghost = true } in [%expr Ppx_quickcheck_runtime.Base.Sequence.map (Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.shrink [%e shrinker] [%e field_expr]) ~f:(fun [%p field_pat] -> [%e make_compound_expr ~loc field_exprs])]))]] ;; let compound (type field) ~shrinker_of_core_type ~loc ~fields (module Field : Field_syntax.S with type ast = field) = let fields = List.map fields ~f:Field.create in let field_pats, field_exprs = gensyms "x" (List.map fields ~f:Field.location) in let shrinker_exprs = List.map fields ~f:(fun field -> shrinker_of_core_type (Field.core_type field)) in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.create (fun [%p Field.pattern fields ~loc field_pats] -> [%e compound_sequence ~loc ~make_compound_expr:(Field.expression fields) ~field_pats ~field_exprs ~shrinker_exprs])] ;; let variant (type clause) ~shrinker_of_core_type ~loc ~variant_type ~clauses (module Clause : Clause_syntax.S with type ast = clause) = let clauses = Clause.create_list clauses in [%expr Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.create [%e pexp_function_cases ~loc (List.map clauses ~f:(fun clause -> let loc = { (Clause.location clause) with loc_ghost = true } in let core_type_list = Clause.core_type_list clause in let field_pats, field_exprs = gensyms "x" (List.map core_type_list ~f:(fun core_type -> core_type.ptyp_loc)) in let shrinker_exprs = List.map core_type_list ~f:shrinker_of_core_type in let lhs = Clause.pattern clause ~loc field_pats in let rhs = compound_sequence ~loc ~make_compound_expr:(Clause.expression clause variant_type) ~field_pats ~field_exprs ~shrinker_exprs in case ~lhs ~guard:None ~rhs))]] ;; base_quickcheck-0.17.1/ppx_quickcheck/expander/ppx_shrinker_expander.mli000066400000000000000000000007111501616613400266220ustar00rootroot00000000000000open! Import val any : loc:location -> expression val arrow : loc:location -> expression val compound : shrinker_of_core_type:(core_type -> expression) -> loc:location -> fields:'a list -> (module Field_syntax.S with type ast = 'a) -> expression val variant : shrinker_of_core_type:(core_type -> expression) -> loc:location -> variant_type:core_type -> clauses:'a list -> (module Clause_syntax.S with type ast = 'a) -> expression base_quickcheck-0.17.1/ppx_quickcheck/runtime/000077500000000000000000000000001501616613400213735ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/runtime/dune000066400000000000000000000002401501616613400222450ustar00rootroot00000000000000(library (name ppx_quickcheck_runtime) (public_name base_quickcheck.ppx_quickcheck.runtime) (libraries base base_quickcheck) (preprocess no_preprocessing)) base_quickcheck-0.17.1/ppx_quickcheck/runtime/ppx_quickcheck_runtime.ml000066400000000000000000000001431501616613400264670ustar00rootroot00000000000000module Base = Base module Base_quickcheck = Base_quickcheck module Quickcheckable = Quickcheckable base_quickcheck-0.17.1/ppx_quickcheck/runtime/quickcheckable.ml000066400000000000000000000021511501616613400246620ustar00rootroot00000000000000open Base_quickcheck module type S = sig type t val quickcheck_generator : t Generator.t val quickcheck_observer : t Observer.t val quickcheck_shrinker : t Shrinker.t end module type S1 = sig type 'a t val quickcheck_generator : 'a Generator.t -> 'a t Generator.t val quickcheck_observer : 'a Observer.t -> 'a t Observer.t val quickcheck_shrinker : 'a Shrinker.t -> 'a t Shrinker.t end module type S2 = sig type ('a, 'b) t val quickcheck_generator : 'a Generator.t -> 'b Generator.t -> ('a, 'b) t Generator.t val quickcheck_observer : 'a Observer.t -> 'b Observer.t -> ('a, 'b) t Observer.t val quickcheck_shrinker : 'a Shrinker.t -> 'b Shrinker.t -> ('a, 'b) t Shrinker.t end module type S3 = sig type ('a, 'b, 'c) t val quickcheck_generator : 'a Generator.t -> 'b Generator.t -> 'c Generator.t -> ('a, 'b, 'c) t Generator.t val quickcheck_observer : 'a Observer.t -> 'b Observer.t -> 'c Observer.t -> ('a, 'b, 'c) t Observer.t val quickcheck_shrinker : 'a Shrinker.t -> 'b Shrinker.t -> 'c Shrinker.t -> ('a, 'b, 'c) t Shrinker.t end base_quickcheck-0.17.1/ppx_quickcheck/src/000077500000000000000000000000001501616613400204775ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/src/dune000066400000000000000000000002561501616613400213600ustar00rootroot00000000000000(library (name ppx_quickcheck) (public_name base_quickcheck.ppx_quickcheck) (kind ppx_deriver) (libraries ppxlib ppx_quickcheck_expander) (preprocess no_preprocessing)) base_quickcheck-0.17.1/ppx_quickcheck/src/ppx_quickcheck.ml000066400000000000000000000006161501616613400240350ustar00rootroot00000000000000open! Base open Ppxlib open Ppx_quickcheck_expander let (_ : Deriving.t) = Deriving.add "quickcheck" ~sig_type_decl ~str_type_decl let (_ : Deriving.t) = Deriving.add "quickcheck.generator" ~extension:generator_extension let (_ : Deriving.t) = Deriving.add "quickcheck.observer" ~extension:observer_extension let (_ : Deriving.t) = Deriving.add "quickcheck.shrinker" ~extension:shrinker_extension base_quickcheck-0.17.1/ppx_quickcheck/src/ppx_quickcheck.mli000066400000000000000000000000551501616613400242030ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) base_quickcheck-0.17.1/ppx_quickcheck/test/000077500000000000000000000000001501616613400206675ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/test/examples/000077500000000000000000000000001501616613400225055ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/test/examples/dune000066400000000000000000000010771501616613400233700ustar00rootroot00000000000000(library (name ppx_quickcheck_test_examples) (libraries base base_quickcheck) (preprocess (pps ppx_quickcheck))) (alias (name DEFAULT) (deps ppx_quickcheck_test_examples_ml_pp.output ppx_quickcheck_test_examples_mli_pp.output)) (rule (targets ppx_quickcheck_test_examples_ml_pp.output) (deps (:first_dep ppx_quickcheck_test_examples.ml.pp)) (action (bash "cp %{first_dep} %{targets}"))) (rule (targets ppx_quickcheck_test_examples_mli_pp.output) (deps (:first_dep ppx_quickcheck_test_examples.mli.pp)) (action (bash "cp %{first_dep} %{targets}"))) base_quickcheck-0.17.1/ppx_quickcheck/test/examples/ppx_quickcheck_test_examples.ml000066400000000000000000000220011501616613400307700ustar00rootroot00000000000000open Base open Base_quickcheck (* ensure that shadowing doesn't break anything *) include struct module Base = struct end module Base_quickcheck = struct end module Quickcheckable = struct end end module Simple_reference = struct type t = bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Dotted_reference = struct type t = Simple_reference.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Nonrec_reference = struct open Dotted_reference type nonrec t = t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Application_of_polymorphic_type = struct type t = bool option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Tuple = struct type t = bool * unit option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_variant = struct (* deliberately make pairs of isomorphic tags to make sure we hash tags properly *) type t = [ `A | `B | `C of bool | `D of bool | `E of bool * unit option | `F of bool * unit option ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Inherit_poly_variant = struct type t = [ `X | Poly_variant.t | `Z of unit option ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Record_type = struct type t = { mutable x : bool ; y : unit option } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Nullary_and_unary_variant = struct (* deliberately make pairs of isomorphic tags to make sure we hash tags properly *) type t = | A | B | C of unit | D of unit [@@deriving quickcheck ~generator ~observer ~shrinker] end module Binary_and_record_variant = struct type t = | A of bool * [ `X | `Y | `Z of unit ] | B of bool * [ `X | `Y | `Z of unit ] | C of { x : unit option ; mutable y : bool } | D of { x : unit option ; mutable y : bool } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Simple_arrow = struct type t = unit option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Named_arrow = struct type t = x:unit option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Optional_arrow = struct type t = ?x:unit option -> unit -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Curried_arrow = struct type t = unit option -> bool option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Simple_higher_order = struct type t = (unit option -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Named_higher_order = struct type t = (x:unit option -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Optional_higher_order = struct type t = (?x:unit option -> unit -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_unary = struct type 'a t = 'a list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_unary = struct type t = bool Poly_unary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_binary = struct type ('a, 'b) t = 'a * 'b [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_binary = struct type t = (bool, unit option) Poly_binary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_ternary = struct type ('a, 'b, 'c) t = 'a * 'b * 'c [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_ternary = struct type t = (bool, unit option, (unit option, bool) Poly_binary.t) Poly_ternary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_with_variance = struct type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_with_variance = struct type t = (bool, unit option) Poly_with_variance.t (* We cannot use [@@deriving quickcheck ~generator ~observer ~shrinker] here because ppx_quickcheck cannot tell the [bool] argument needs to swap generators with observers. *) let quickcheck_generator = Poly_with_variance.quickcheck_generator quickcheck_observer_bool (quickcheck_generator_option quickcheck_generator_unit) ;; let quickcheck_observer = Poly_with_variance.quickcheck_observer quickcheck_generator_bool (quickcheck_observer_option quickcheck_observer_unit) ;; let quickcheck_shrinker = Poly_with_variance.quickcheck_shrinker quickcheck_shrinker_bool (quickcheck_shrinker_option quickcheck_shrinker_unit) ;; let _quickcheck_generator_with_custom = [%quickcheck.generator: [ `Foo of [%custom quickcheck_generator] ]] ;; end module Poly_with_phantom = struct type _ t = unit option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_with_phantom = struct type t = [ `phantom ] Poly_with_phantom.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Recursive = struct type t = | Leaf | Node of t * t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Recursive_with_indirect_base_case = struct type t = { children : t list } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Mutually_recursive = struct type expr = | Constant of int64 | Operator of op | Application of expr * args and op = [ `plus | `minus | `abs ] and args = expr list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_recursive = struct type 'a t = | Zero | Succ of 'a * 'a t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_recursive = struct type t = bool Poly_recursive.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Murec_poly_mono = struct type t = | Leaf of bool | Node of t node and 'a node = 'a list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Polymorphic_recursion = struct type 'a t = | Single of 'a | Double of ('a * 'a) t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Extensions = struct type t = [ `A | `B of bool * unit option ] let quickcheck_generator = [%quickcheck.generator: [ `A | `B of bool * unit option ]] let quickcheck_observer = [%quickcheck.observer: [ `A | `B of bool * unit option ]] let quickcheck_shrinker = [%quickcheck.shrinker: [ `A | `B of bool * unit option ]] end module Escaped = struct type t = int * char * bool option let quickcheck_generator = [%quickcheck.generator: [%custom Generator.small_strictly_positive_int] * char * bool option] ;; let quickcheck_observer = [%quickcheck.observer: int * [%custom Observer.opaque] * bool option] ;; let quickcheck_shrinker = [%quickcheck.shrinker: int * char * [%custom Shrinker.atomic]] end module Wildcard (Elt : sig type t val examples : t list end) = struct type t = Elt.t list let quickcheck_generator = Generator.list (Generator.of_list Elt.examples) let quickcheck_observer : t Observer.t = [%quickcheck.observer: _ list] let quickcheck_shrinker : t Shrinker.t = [%quickcheck.shrinker: _ list] end module Attribute_override = struct type t = | Null [@quickcheck.weight 0.1] | Text of (string[@quickcheck.generator Generator.string_of Generator.char_lowercase]) | Number of (float[@quickcheck.generator Generator.float_strictly_positive]) [@@deriving quickcheck ~generator ~observer ~shrinker] end module Attribute_override_recursive = struct type t = | Leaf | Node1 of t * int64 * t [@quickcheck.weight 0.5] | Node2 of t * int64 * t * int64 * t [@quickcheck.weight 0.25] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Deriving_from_wildcard = struct type _ transparent = string [@@deriving quickcheck ~generator ~observer ~shrinker] type 'a opaque = 'a option [@@deriving quickcheck ~generator ~observer ~shrinker] let compare_opaque = compare_option let sexp_of_opaque = sexp_of_option let opaque_examples = [ None; Some 0L; Some 1L ] end module Do_not_generate_clauses = struct module Cannot_generate = struct type t = bool option let all = None :: List.map Bool.all ~f:Option.return let compare = Option.compare Bool.compare let sexp_of_t = Option.sexp_of_t Bool.sexp_of_t let quickcheck_observer = quickcheck_observer_option quickcheck_observer_bool let quickcheck_shrinker = quickcheck_shrinker_option quickcheck_shrinker_bool end type t = | Can_generate of bool | Cannot_generate of Cannot_generate.t [@quickcheck.do_not_generate] [@@deriving quickcheck ~generator ~observer ~shrinker] module Poly = struct type t = [ `Can_generate of bool | `Cannot_generate of Cannot_generate.t [@quickcheck.do_not_generate] ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module _ = struct type t = | A | B of t [@quickcheck.do_not_generate] [@@deriving quickcheck ~generator ~observer ~shrinker] end end base_quickcheck-0.17.1/ppx_quickcheck/test/examples/ppx_quickcheck_test_examples.mli000066400000000000000000000153331501616613400311530ustar00rootroot00000000000000open Base (* ensure that shadowing doesn't break anything *) include module type of struct module Base = struct end module Base_quickcheck = struct end module Quickcheckable = struct end end module Simple_reference : sig type t = bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Dotted_reference : sig type t = Simple_reference.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Nonrec_reference : sig open Dotted_reference type nonrec t = t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Application_of_polymorphic_type : sig type t = bool option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Tuple : sig type t = bool * unit option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_variant : sig type t = [ `A | `B | `C of bool | `D of bool | `E of bool * unit option | `F of bool * unit option ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Inherit_poly_variant : sig type t = [ `X | Poly_variant.t | `Z of unit option ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Record_type : sig type t = { mutable x : bool ; y : unit option } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Nullary_and_unary_variant : sig type t = | A | B | C of unit | D of unit [@@deriving quickcheck ~generator ~observer ~shrinker] end module Binary_and_record_variant : sig type t = | A of bool * [ `X | `Y | `Z of unit ] | B of bool * [ `X | `Y | `Z of unit ] | C of { x : unit option ; mutable y : bool } | D of { x : unit option ; mutable y : bool } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Simple_arrow : sig type t = unit option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Named_arrow : sig type t = x:unit option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Optional_arrow : sig type t = ?x:unit option -> unit -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Curried_arrow : sig type t = unit option -> bool option -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Simple_higher_order : sig type t = (unit option -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Named_higher_order : sig type t = (x:unit option -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Optional_higher_order : sig type t = (?x:unit option -> unit -> bool option) -> bool [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_unary : sig type 'a t = 'a list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_unary : sig type t = bool Poly_unary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_binary : sig type ('a, 'b) t = 'a * 'b [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_binary : sig type t = (bool, unit option) Poly_binary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_ternary : sig type ('a, 'b, 'c) t = 'a * 'b * 'c [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_ternary : sig type t = (bool, unit option, (unit option, bool) Poly_binary.t) Poly_ternary.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_with_variance : sig type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_with_variance : sig type t = (bool, unit option) Poly_with_variance.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_with_phantom : sig type _ t [@@deriving quickcheck ~generator ~observer ~shrinker] end with type _ t = unit option module Instance_with_phantom : sig type t = [ `phantom ] Poly_with_phantom.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Recursive : sig type t = | Leaf | Node of t * t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Recursive_with_indirect_base_case : sig type t = { children : t list } [@@deriving quickcheck ~generator ~observer ~shrinker] end module Mutually_recursive : sig type expr = | Constant of int64 | Operator of op | Application of expr * args and op = [ `plus | `minus | `abs ] and args = expr list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Poly_recursive : sig type 'a t = | Zero | Succ of 'a * 'a t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Instance_of_recursive : sig type t = bool Poly_recursive.t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Murec_poly_mono : sig type t = | Leaf of bool | Node of t node and 'a node = 'a list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Polymorphic_recursion : sig type 'a t = | Single of 'a | Double of ('a * 'a) t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Extensions : sig type t = [ `A | `B of bool * unit option ] [@@deriving quickcheck ~generator ~observer ~shrinker] end module Escaped : sig type t = int * char * bool option [@@deriving quickcheck ~generator ~observer ~shrinker] end module Wildcard (Elt : sig type t val examples : t list end) : sig type t = Elt.t list [@@deriving quickcheck ~generator ~observer ~shrinker] end module Attribute_override : sig type t = | Null | Text of string | Number of float [@@deriving quickcheck ~generator ~observer ~shrinker] end module Attribute_override_recursive : sig type t = | Leaf | Node1 of t * int64 * t | Node2 of t * int64 * t * int64 * t [@@deriving quickcheck ~generator ~observer ~shrinker] end module Deriving_from_wildcard : sig type _ transparent = string [@@deriving quickcheck ~generator ~observer ~shrinker] type _ opaque [@@deriving quickcheck ~generator ~observer ~shrinker] val compare_opaque : ('a -> 'a -> int) -> 'a opaque -> 'a opaque -> int val sexp_of_opaque : ('a -> Sexp.t) -> 'a opaque -> Sexp.t val opaque_examples : int64 opaque list end module Do_not_generate_clauses : sig module Cannot_generate : sig type t val all : t list val compare : t -> t -> int val sexp_of_t : t -> Sexp.t end type t = | Can_generate of bool | Cannot_generate of Cannot_generate.t [@@deriving quickcheck ~generator ~observer ~shrinker] module Poly : sig type t = [ `Can_generate of bool | `Cannot_generate of Cannot_generate.t ] [@@deriving quickcheck ~generator ~observer ~shrinker] end end base_quickcheck-0.17.1/ppx_quickcheck/test/examples/ppx_quickcheck_test_examples_with_flags.ml000066400000000000000000000140611501616613400332060ustar00rootroot00000000000000open Base open Base_quickcheck (* ensure that shadowing doesn't break anything *) include struct module Base = struct end module Base_quickcheck = struct end module Quickcheckable = struct end end module Generator = struct module Simple_reference = struct type t = bool [@@deriving_inline quickcheck ~generator] let _ = fun (_ : t) -> () let quickcheck_generator = quickcheck_generator_bool let _ = quickcheck_generator [@@@end] end module Simple_arrow = struct type t = unit option -> bool [@@deriving_inline quickcheck ~generator] let _ = fun (_ : t) -> () let quickcheck_generator = Ppx_quickcheck_runtime.Base_quickcheck.Generator.fn (quickcheck_observer_option quickcheck_observer_unit) quickcheck_generator_bool ;; let _ = quickcheck_generator [@@@end] end module Simple_higher_order = struct type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~generator] let _ = fun (_ : t) -> () let quickcheck_generator = Ppx_quickcheck_runtime.Base_quickcheck.Generator.fn (Ppx_quickcheck_runtime.Base_quickcheck.Observer.fn (quickcheck_generator_option quickcheck_generator_unit) (quickcheck_observer_option quickcheck_observer_bool)) quickcheck_generator_bool ;; let _ = quickcheck_generator [@@@end] end module Poly_with_variance = struct type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~generator] let _ = fun (_ : ('a, 'b) t) -> () let quickcheck_generator _observer__001_ _generator__002_ = Ppx_quickcheck_runtime.Base_quickcheck.Generator.create (fun ~size:_size__003_ ~random:_random__004_ -> ( Ppx_quickcheck_runtime.Base_quickcheck.Generator.generate _generator__002_ ~size:_size__003_ ~random:_random__004_ , Ppx_quickcheck_runtime.Base_quickcheck.Generator.generate (Ppx_quickcheck_runtime.Base_quickcheck.Generator.fn _observer__001_ _generator__002_) ~size:_size__003_ ~random:_random__004_ )) ;; let _ = quickcheck_generator [@@@end] end end module Observer = struct module Simple_reference = struct type t = bool [@@deriving_inline quickcheck ~observer] let _ = fun (_ : t) -> () let quickcheck_observer = quickcheck_observer_bool let _ = quickcheck_observer [@@@end] end module Simple_arrow = struct type t = unit option -> bool [@@deriving_inline quickcheck ~observer] let _ = fun (_ : t) -> () let quickcheck_observer = Ppx_quickcheck_runtime.Base_quickcheck.Observer.fn (quickcheck_generator_option quickcheck_generator_unit) quickcheck_observer_bool ;; let _ = quickcheck_observer [@@@end] end module Simple_higher_order = struct type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~observer] let _ = fun (_ : t) -> () let quickcheck_observer = Ppx_quickcheck_runtime.Base_quickcheck.Observer.fn (Ppx_quickcheck_runtime.Base_quickcheck.Generator.fn (quickcheck_observer_option quickcheck_observer_unit) (quickcheck_generator_option quickcheck_generator_bool)) quickcheck_observer_bool ;; let _ = quickcheck_observer [@@@end] end module Poly_with_variance = struct type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~observer] let _ = fun (_ : ('a, 'b) t) -> () let quickcheck_observer _generator__005_ _observer__006_ = Ppx_quickcheck_runtime.Base_quickcheck.Observer.create (fun _x__007_ ~size:_size__010_ ~hash:_hash__011_ -> let _x__008_, _x__009_ = _x__007_ in let _hash__011_ = Ppx_quickcheck_runtime.Base_quickcheck.Observer.observe _observer__006_ _x__008_ ~size:_size__010_ ~hash:_hash__011_ in let _hash__011_ = Ppx_quickcheck_runtime.Base_quickcheck.Observer.observe (Ppx_quickcheck_runtime.Base_quickcheck.Observer.fn _generator__005_ _observer__006_) _x__009_ ~size:_size__010_ ~hash:_hash__011_ in _hash__011_) ;; let _ = quickcheck_observer [@@@end] end end module Shrinker = struct module Simple_reference = struct type t = bool [@@deriving_inline quickcheck ~shrinker] let _ = fun (_ : t) -> () let quickcheck_shrinker = quickcheck_shrinker_bool let _ = quickcheck_shrinker [@@@end] end module Simple_arrow = struct type t = unit option -> bool [@@deriving_inline quickcheck ~shrinker] let _ = fun (_ : t) -> () let quickcheck_shrinker = Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.atomic let _ = quickcheck_shrinker [@@@end] end module Simple_higher_order = struct type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~shrinker] let _ = fun (_ : t) -> () let quickcheck_shrinker = Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.atomic let _ = quickcheck_shrinker [@@@end] end module Poly_with_variance = struct type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~shrinker] let _ = fun (_ : ('a, 'b) t) -> () let quickcheck_shrinker _shrinker__012_ _shrinker__013_ = Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.create (fun (_x__014_, _x__015_) -> Ppx_quickcheck_runtime.Base.Sequence.round_robin [ Ppx_quickcheck_runtime.Base.Sequence.map (Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.shrink _shrinker__013_ _x__014_) ~f:(fun _x__014_ -> _x__014_, _x__015_) ; Ppx_quickcheck_runtime.Base.Sequence.map (Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.shrink Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.atomic _x__015_) ~f:(fun _x__015_ -> _x__014_, _x__015_) ]) ;; let _ = quickcheck_shrinker [@@@end] end end base_quickcheck-0.17.1/ppx_quickcheck/test/examples/ppx_quickcheck_test_examples_with_flags.mli000066400000000000000000000103331501616613400333550ustar00rootroot00000000000000open Base (* ensure that shadowing doesn't break anything *) include module type of struct module Base = struct end module Base_quickcheck = struct end module Quickcheckable = struct end end module Generator : sig module Simple_reference : sig type t = bool [@@deriving_inline quickcheck ~generator] include sig [@@@ocaml.warning "-32"] val quickcheck_generator : t Ppx_quickcheck_runtime.Base_quickcheck.Generator.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_arrow : sig type t = unit option -> bool [@@deriving_inline quickcheck ~generator] include sig [@@@ocaml.warning "-32"] val quickcheck_generator : t Ppx_quickcheck_runtime.Base_quickcheck.Generator.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_higher_order : sig type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~generator] include sig [@@@ocaml.warning "-32"] val quickcheck_generator : t Ppx_quickcheck_runtime.Base_quickcheck.Generator.t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_with_variance : sig type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~generator] include sig [@@@ocaml.warning "-32"] val quickcheck_generator : 'a Ppx_quickcheck_runtime.Base_quickcheck.Observer.t -> 'b Ppx_quickcheck_runtime.Base_quickcheck.Generator.t -> ('a, 'b) t Ppx_quickcheck_runtime.Base_quickcheck.Generator.t end [@@ocaml.doc "@inline"] [@@@end] end end module Observer : sig module Simple_reference : sig type t = bool [@@deriving_inline quickcheck ~observer] include sig [@@@ocaml.warning "-32"] val quickcheck_observer : t Ppx_quickcheck_runtime.Base_quickcheck.Observer.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_arrow : sig type t = unit option -> bool [@@deriving_inline quickcheck ~observer] include sig [@@@ocaml.warning "-32"] val quickcheck_observer : t Ppx_quickcheck_runtime.Base_quickcheck.Observer.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_higher_order : sig type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~observer] include sig [@@@ocaml.warning "-32"] val quickcheck_observer : t Ppx_quickcheck_runtime.Base_quickcheck.Observer.t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_with_variance : sig type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~observer] include sig [@@@ocaml.warning "-32"] val quickcheck_observer : 'a Ppx_quickcheck_runtime.Base_quickcheck.Generator.t -> 'b Ppx_quickcheck_runtime.Base_quickcheck.Observer.t -> ('a, 'b) t Ppx_quickcheck_runtime.Base_quickcheck.Observer.t end [@@ocaml.doc "@inline"] [@@@end] end end module Shrinker : sig module Simple_reference : sig type t = bool [@@deriving_inline quickcheck ~shrinker] include sig [@@@ocaml.warning "-32"] val quickcheck_shrinker : t Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_arrow : sig type t = unit option -> bool [@@deriving_inline quickcheck ~shrinker] include sig [@@@ocaml.warning "-32"] val quickcheck_shrinker : t Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t end [@@ocaml.doc "@inline"] [@@@end] end module Simple_higher_order : sig type t = (unit option -> bool option) -> bool [@@deriving_inline quickcheck ~shrinker] include sig [@@@ocaml.warning "-32"] val quickcheck_shrinker : t Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_with_variance : sig type (-'a, +'b) t = 'b * ('a -> 'b) [@@deriving_inline quickcheck ~shrinker] include sig [@@@ocaml.warning "-32"] val quickcheck_shrinker : 'a Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t -> 'b Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t -> ('a, 'b) t Ppx_quickcheck_runtime.Base_quickcheck.Shrinker.t end [@@ocaml.doc "@inline"] [@@@end] end end base_quickcheck-0.17.1/ppx_quickcheck/test/src/000077500000000000000000000000001501616613400214565ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/test/src/dune000066400000000000000000000003141501616613400223320ustar00rootroot00000000000000(library (name test_ppx_quickcheck) (libraries base base_quickcheck base_quickcheck_test_helpers expect_test_helpers_core ppx_quickcheck_test_examples) (preprocess (pps ppx_jane ppx_quickcheck))) base_quickcheck-0.17.1/ppx_quickcheck/test/src/import.ml000066400000000000000000000001531501616613400233210ustar00rootroot00000000000000include Base include Base_quickcheck include Base_quickcheck_test_helpers include Expect_test_helpers_core base_quickcheck-0.17.1/ppx_quickcheck/test/src/test_ppx_quickcheck.ml000066400000000000000000000570021501616613400260540ustar00rootroot00000000000000open! Import open Ppx_quickcheck_test_examples open struct module type S = sig type t val quickcheck_generator : t Generator.t val quickcheck_observer : t Observer.t val quickcheck_shrinker : t Shrinker.t end (* consistent trial count on 32- and 64-bit systems *) let config = { Test.default_config with test_count = 10_000 } let test (type a) ?(config = config) ?cr ?generator ?observer ?shrinker q m = let (module Q : S with type t = a) = q in test_generator ~config ?cr ?mode:generator Q.quickcheck_generator m; test_observer ~config ?cr ?mode:observer Q.quickcheck_observer m; test_shrinker ~config ?cr ?mode:shrinker Q.quickcheck_shrinker m ;; module type All = sig type t [@@deriving compare, enumerate, sexp_of] end let m_all (type a) (module M : All with type t = a) = (module struct include M let examples = all end : With_examples with type t = a) ;; end include struct module Base = struct end module Base_quickcheck = struct end module Quickcheckable = struct end end module Simple_reference = Simple_reference module Dotted_reference = Dotted_reference module Nonrec_reference = Nonrec_reference let%expect_test "type names" = test ~shrinker:`atomic (module Simple_reference) m_bool; [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; test ~shrinker:`atomic (module Dotted_reference) m_bool; [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; test ~shrinker:`atomic (module Nonrec_reference) m_bool; [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}] ;; module Application_of_polymorphic_type = Application_of_polymorphic_type let%expect_test "application of polymorphic type" = test (module Application_of_polymorphic_type) (m_option m_bool); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((false) => ()) ((true) => ()))) |}] ;; module Tuple = Tuple let%expect_test "tuple" = test (module Tuple) (m_pair m_bool (m_option m_unit)); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((false (())) => (false ())) ((true (())) => (true ())))) |}] ;; module Poly_variant = Poly_variant module Inherit_poly_variant = Inherit_poly_variant let%expect_test "polymorphic variant" = let module Poly_variant' = struct type t = [ `A | `B | `C of bool | `D of bool | `E of bool * unit option | `F of bool * unit option ] [@@deriving compare, enumerate, sexp_of] end in test (module Poly_variant) (m_all (module Poly_variant')); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((E (false (()))) => (E (false ()))) ((E (true (()))) => (E (true ()))) ((F (false (()))) => (F (false ()))) ((F (true (()))) => (F (true ()))))) |}]; let module Inherit_poly_variant' = struct type t = [ `X | Poly_variant'.t | `Z of unit option ] [@@deriving compare, enumerate, sexp_of] end in test (module Inherit_poly_variant) (m_all (module Inherit_poly_variant')); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((E (false (()))) => (E (false ()))) ((E (true (()))) => (E (true ()))) ((F (false (()))) => (F (false ()))) ((F (true (()))) => (F (true ()))) ((Z (())) => (Z ())))) |}] ;; module Record_type = Record_type let%expect_test "record type" = let module Record_type' = struct type t = Record_type.t = { mutable x : bool ; y : unit option } [@@deriving compare, enumerate, sexp_of] end in test (module Record_type) (m_all (module Record_type')); [%expect {| (generator exhaustive) (observer transparent) (shrinker ((((x false) (y (()))) => ((x false) (y ()))) (((x true) (y (()))) => ((x true) (y ()))))) |}] ;; module Nullary_and_unary_variant = Nullary_and_unary_variant module Binary_and_record_variant = Binary_and_record_variant let%expect_test "variant type" = let module Nullary_and_unary_variant' = struct type t = Nullary_and_unary_variant.t = | A | B | C of unit | D of unit [@@deriving compare, enumerate, sexp_of] end in test ~shrinker:`atomic (module Nullary_and_unary_variant) (m_all (module Nullary_and_unary_variant')); [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; let module Binary_and_record_variant' = struct type t = Binary_and_record_variant.t = | A of bool * [ `X | `Y | `Z of unit ] | B of bool * [ `X | `Y | `Z of unit ] | C of { x : unit option ; mutable y : bool } | D of { x : unit option ; mutable y : bool } [@@deriving compare, enumerate, sexp_of] end in test (module Binary_and_record_variant) (m_all (module Binary_and_record_variant')); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((C (x (())) (y false)) => (C (x ()) (y false))) ((C (x (())) (y true)) => (C (x ()) (y true))) ((D (x (())) (y false)) => (D (x ()) (y false))) ((D (x (())) (y true)) => (D (x ()) (y true))))) |}] ;; module Simple_arrow = Simple_arrow module Named_arrow = Named_arrow module Optional_arrow = Optional_arrow module Curried_arrow = Curried_arrow let%expect_test "first order arrow type" = let config = { Test.default_config with test_count = 1_000 } in let test ?cr ?(config = config) m = test ?cr ~config ~shrinker:`atomic m in test (module Simple_arrow) (m_arrow (m_option m_unit) m_bool); [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; test (module Named_arrow) (m_arrow_named (m_option m_unit) m_bool); [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; test (module Optional_arrow) (m_arrow_optional (m_option m_unit) m_bool); [%expect {| (generator exhaustive) (observer transparent) (shrinker atomic) |}]; test (module Curried_arrow) (m_arrow (m_option m_unit) (m_arrow (m_option m_bool) m_bool)); [%expect {| (generator "generated 64 distinct values in 1_000 iterations") (observer transparent) (shrinker atomic) |}] ;; module Simple_higher_order = Simple_higher_order module Named_higher_order = Named_higher_order module Optional_higher_order = Optional_higher_order let%expect_test ("higher order arrow type" [@tags "64-bits-only"]) = let config = { Test.default_config with test_count = 100 } in let test m = test ~config ~shrinker:`atomic m in test (module Simple_higher_order) (m_arrow (m_arrow (m_option m_unit) (m_option m_bool)) m_bool); [%expect {| (generator "generated 55 distinct values in 100 iterations") (observer transparent) (shrinker atomic) |}]; test (module Named_higher_order) (m_arrow (m_arrow_named (m_option m_unit) (m_option m_bool)) m_bool); [%expect {| (generator "generated 55 distinct values in 100 iterations") (observer transparent) (shrinker atomic) |}]; test (module Optional_higher_order) (m_arrow (m_arrow_optional (m_option m_unit) (m_option m_bool)) m_bool); [%expect {| (generator "generated 49 distinct values in 100 iterations") (observer transparent) (shrinker atomic) |}] ;; module Poly_unary = Poly_unary module Instance_of_unary = Instance_of_unary module Poly_binary = Poly_binary module Instance_of_binary = Instance_of_binary module Poly_ternary = Poly_ternary module Instance_of_ternary = Instance_of_ternary module Poly_with_variance = Poly_with_variance module Instance_with_variance = Instance_with_variance module Poly_with_phantom = Poly_with_phantom module Instance_with_phantom = Instance_with_phantom let%expect_test "polymorphic type" = test (module Instance_of_unary) (m_list m_bool); [%expect {| (generator "generated 2_248 distinct values in 10_000 iterations") (observer transparent) (shrinker (((false) => ()) ((true) => ()) ((false true) => (true)) ((false true) => (false)) ((true false) => (false)) ((true false) => (true)))) |}]; test (module Instance_of_binary) (m_pair m_bool (m_option m_unit)); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((false (())) => (false ())) ((true (())) => (true ())))) |}]; test (module Instance_of_ternary) (m_triple m_bool (m_option m_unit) (m_pair (m_option m_unit) m_bool)); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((false () ((()) false)) => (false () (() false))) ((false () ((()) true)) => (false () (() true))) ((false (()) (() false)) => (false () (() false))) ((false (()) (() true)) => (false () (() true))) ((false (()) ((()) false)) => (false () ((()) false))) ((false (()) ((()) false)) => (false (()) (() false))) ((false (()) ((()) true)) => (false () ((()) true))) ((false (()) ((()) true)) => (false (()) (() true))) ((true () ((()) false)) => (true () (() false))) ((true () ((()) true)) => (true () (() true))) ((true (()) (() false)) => (true () (() false))) ((true (()) (() true)) => (true () (() true))) ((true (()) ((()) false)) => (true () ((()) false))) ((true (()) ((()) false)) => (true (()) (() false))) ((true (()) ((()) true)) => (true () ((()) true))) ((true (()) ((()) true)) => (true (()) (() true))))) |}]; test (module Instance_with_variance) (m_pair (m_option m_unit) (m_arrow m_bool (m_option m_unit))); [%expect {| (generator exhaustive) (observer transparent) (shrinker ((((()) ((false ()) (true ()))) => (() ((false ()) (true ())))) (((()) ((false ()) (true (())))) => (() ((false ()) (true (()))))) (((()) ((false (())) (true ()))) => (() ((false (())) (true ())))) (((()) ((false (())) (true (())))) => (() ((false (())) (true (()))))))) |}]; test (module Instance_with_phantom) (m_option m_unit); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((()) => ()))) |}] ;; module Recursive = Recursive let%expect_test "recursive type" = let module Recursive' = struct type t = Recursive.t = | Leaf | Node of t * t [@@deriving compare, hash, sexp_of] let rec create = function | 0 -> Leaf | n -> let t = create (n - 1) in Node (t, t) ;; let examples = List.init 3 ~f:create end in test ~shrinker:`atomic (module Recursive) (module Recursive'); [%expect {| (generator "generated 1_954 distinct values in 10_000 iterations") (observer transparent) (shrinker atomic) |}] ;; module Recursive_with_indirect_base_case = Recursive_with_indirect_base_case let%expect_test "recursive type with indirect base case" = let module Recursive_with_indirect_base_case' = struct type t = Recursive_with_indirect_base_case.t = { children : t list } [@@deriving compare, hash, sexp_of] let examples = List.init 3 ~f:(fun n -> { children = List.init n ~f:(Fn.const { children = [] }) }) ;; end in test (module Recursive_with_indirect_base_case) (module Recursive_with_indirect_base_case'); [%expect {| (generator "generated 4_507 distinct values in 10_000 iterations") (observer transparent) (shrinker ((((children (((children ()))))) => ((children ()))) (((children (((children ())) ((children ()))))) => ((children (((children ())))))) (((children (((children ())) ((children ()))))) => ((children (((children ())))))))) |}] ;; module Mutually_recursive = Mutually_recursive let%expect_test "mutually recursive types" = let module Mutually_recursive' = struct type expr = Mutually_recursive.expr = | Constant of int64 | Operator of op | Application of expr * args and op = [ `plus | `minus | `abs ] and args = expr list [@@deriving compare, hash, sexp_of] end in test ~shrinker:`atomic (module struct type t = Mutually_recursive.expr [@@deriving quickcheck] end) (module struct type t = Mutually_recursive'.expr [@@deriving compare, hash, sexp_of] let examples : t list = [ Constant 0L; Operator `plus; Application (Operator `abs, []) ] ;; end); [%expect {| (generator "generated 5_895 distinct values in 10_000 iterations") (observer transparent) (shrinker atomic) |}] ;; module Poly_recursive = Poly_recursive module Instance_of_recursive = Instance_of_recursive let%expect_test "polymorphic, recursive type" = let module Poly_recursive' = struct type 'a t = 'a Poly_recursive.t = | Zero | Succ of 'a * 'a t [@@deriving compare, sexp_of] let rec of_list = function | [] -> Zero | head :: tail -> Succ (head, of_list tail) ;; let examples (type a) (m_elt : (module With_examples with type t = a)) = let module M = (val m_list m_elt) in List.map M.examples ~f:of_list ;; end in let module Instance_of_recursive' = struct type t = bool Poly_recursive'.t [@@deriving compare, sexp_of] let examples = Poly_recursive'.examples m_bool end in test ~shrinker:`atomic (module Instance_of_recursive) (module Instance_of_recursive'); [%expect {| (generator "generated 154 distinct values in 10_000 iterations") (observer transparent) (shrinker atomic) |}] ;; module Murec_poly_mono = Murec_poly_mono let%expect_test "mutually recursive polymorphic and monomorphic types" = let module Murec_poly_mono' = struct type t = Murec_poly_mono.t = | Leaf of bool | Node of t node and 'a node = 'a list [@@deriving compare, sexp_of] let examples = [ Leaf false; Node []; Node [ Leaf true ] ] end in test (module Murec_poly_mono) (module Murec_poly_mono'); [%expect {| (generator "generated 2_343 distinct values in 10_000 iterations") (observer transparent) (shrinker (((Node ((Leaf true))) => (Node ())))) |}] ;; module Polymorphic_recursion = Polymorphic_recursion let%expect_test "type using polymorphic recursion" = let module Instance = struct type t = bool option Polymorphic_recursion.t [@@deriving quickcheck] end in let module Polymorphic_recursion' = struct type 'a t = 'a Polymorphic_recursion.t = | Single of 'a | Double of ('a * 'a) t [@@deriving compare, sexp_of] end in let module Instance' = struct type t = bool option Polymorphic_recursion'.t [@@deriving compare, sexp_of] let examples : t list = [ Single None ; Double (Single (Some true, Some false)) ; Double (Double (Single ((Some true, Some false), (Some true, Some false)))) ] ;; end in test (module Instance) (module Instance'); [%expect {| (generator "generated 1_170 distinct values in 10_000 iterations") (observer transparent) (shrinker (((Double (Single ((true) (false)))) => (Double (Single (() (false))))) ((Double (Single ((true) (false)))) => (Double (Single ((true) ())))) ((Double (Double (Single (((true) (false)) ((true) (false)))))) => (Double (Double (Single ((() (false)) ((true) (false))))))) ((Double (Double (Single (((true) (false)) ((true) (false)))))) => (Double (Double (Single (((true) (false)) (() (false))))))) ((Double (Double (Single (((true) (false)) ((true) (false)))))) => (Double (Double (Single (((true) ()) ((true) (false))))))) ((Double (Double (Single (((true) (false)) ((true) (false)))))) => (Double (Double (Single (((true) (false)) ((true) ())))))))) |}] ;; module Extensions = Extensions let%expect_test "extensions" = let module Extensions' = struct type t = [ `A | `B of bool * unit option ] [@@deriving compare, enumerate, sexp_of] end in test (module Extensions) (m_all (module Extensions')); [%expect {| (generator exhaustive) (observer transparent) (shrinker (((B (false (()))) => (B (false ()))) ((B (true (()))) => (B (true ()))))) |}] ;; module Escaped = Escaped let%expect_test "escaped" = let module Escaped' = struct type t = int * char * bool option [@@deriving compare, sexp_of] let examples = List.concat_map [ 1; 2 ] ~f:(fun int -> List.concat_map [ 'a'; 'b' ] ~f:(fun string -> List.concat_map [ None; Some true ] ~f:(fun bool_option -> [ int, string, bool_option ]))) ;; end in (* We disable CRs in test output because the observer is neither strictly transparent nor strictly opaque, so it will fail the test in either observer mode we give it. *) test ~cr:Comment ~shrinker:`atomic (module Escaped) (module Escaped'); [%expect {| (generator "generated 4_992 distinct values in 10_000 iterations") (observer (partitions (((1 a ()) (1 b ())) ((1 a (true)) (1 b (true))) ((2 a ()) (2 b ())) ((2 a (true)) (2 b (true)))))) (* require-failed: lib/base_quickcheck/test/helpers/base_quickcheck_test_helpers.ml:LINE:COL. *) "did not generate any single function that distinguishes all values" (shrinker atomic) |}] ;; module Wildcard = Wildcard let%expect_test "wildcard" = let module Instance = struct include Wildcard ((val m_bool)) let compare = [%compare: bool list] let sexp_of_t = [%sexp_of: bool list] let examples = let module T = (val m_list m_bool) in T.examples ;; end in (* We disable CRs in test output because the observer is neither strictly transparent nor strictly opaque, so it will fail the test in either observer mode we give it. *) test ~cr:Comment (module Instance) (module Instance); [%expect {| (generator "generated 2_248 distinct values in 10_000 iterations") (observer (partitions ((()) ((false) (true)) ((false true) (true false))))) (* require-failed: lib/base_quickcheck/test/helpers/base_quickcheck_test_helpers.ml:LINE:COL. *) "did not generate any single function that distinguishes all values" (shrinker (((false) => ()) ((true) => ()) ((false true) => (true)) ((false true) => (false)) ((true false) => (false)) ((true false) => (true)))) |}] ;; module Attribute_override = Attribute_override let%expect_test "attributes" = let module Attribute_override' = struct type t = Attribute_override.t = | Null | Text of string | Number of float [@@deriving compare, sexp_of] let examples = [ Null; Text "a"; Number 1. ] end in test (module Attribute_override) (module Attribute_override'); [%expect {| (generator "generated 8_470 distinct values in 10_000 iterations") (observer transparent) (shrinker (((Text a) => (Text "")))) |}]; show_distribution ~config Attribute_override.quickcheck_generator (module Attribute_override'); [%expect {| ((4.35% Null) (4.12% (Text "")) (50bp (Number 1)) (27bp (Number 4.94065645841247E-324)) (23bp (Number 2.2250738585072009E-308)) (21bp (Text m)) (19bp (Text q)) (19bp (Text n)) (16bp (Text h)) (16bp (Text c)) (15bp (Number 8.98846567431158E+307)) (15bp (Text y)) (15bp (Text v)) (15bp (Text u)) (15bp (Text o)) (15bp (Text l)) (15bp (Text e)) (14bp (Number 0.5)) (14bp (Text r)) (14bp (Text i))) |}] ;; module Attribute_override_recursive = Attribute_override_recursive let%expect_test "attributes for recursive types" = let module Attribute_override_recursive' = struct type t = Attribute_override_recursive.t = | Leaf | Node1 of t * int64 * t | Node2 of t * int64 * t * int64 * t [@@deriving compare, sexp_of] let examples = [ Leaf; Node1 (Leaf, 0L, Leaf); Node2 (Leaf, 0L, Leaf, 0L, Leaf) ] end in test ~shrinker:`atomic (module Attribute_override_recursive) (module Attribute_override_recursive'); [%expect {| (generator "generated 4_007 distinct values in 10_000 iterations") (observer transparent) (shrinker atomic) |}]; show_distribution ~config Attribute_override_recursive.quickcheck_generator (module Attribute_override_recursive'); [%expect {| ((58.49% Leaf) (27bp (Node1 Leaf -1 Leaf)) (26bp (Node1 Leaf -9223372036854775808 Leaf)) (25bp (Node1 Leaf 0 Leaf)) (24bp (Node1 Leaf 9223372036854775807 Leaf)) (9bp (Node1 Leaf -2 Leaf)) (7bp (Node1 Leaf 1 Leaf)) (5bp (Node1 Leaf -3 Leaf)) (4bp (Node1 Leaf 3 Leaf)) (4bp (Node1 Leaf -4 Leaf)) (4bp (Node1 Leaf -6 Leaf)) (3bp (Node2 Leaf -9223372036854775808 Leaf -9223372036854775808 Leaf)) (3bp (Node1 Leaf 15 Leaf)) (3bp (Node1 Leaf 10 Leaf)) (3bp (Node1 Leaf 8 Leaf)) (3bp (Node1 Leaf 6 Leaf)) (2bp (Node2 Leaf -1 Leaf 9223372036854775807 Leaf)) (2bp (Node1 Leaf 98 Leaf)) (2bp (Node1 Leaf 83 Leaf)) (2bp (Node1 Leaf 29 Leaf))) |}] ;; module Deriving_from_wildcard = Deriving_from_wildcard let%expect_test "polymorphic wildcard" = let module Transparent = struct type t = int Deriving_from_wildcard.transparent [@@deriving quickcheck] let compare = [%compare: string] let sexp_of_t = [%sexp_of: string] let examples = [ ""; "a" ] end in test (module Transparent) (module Transparent); [%expect {| (generator "generated 8_583 distinct values in 10_000 iterations") (observer transparent) (shrinker ((a => ""))) |}]; let module Opaque = struct type t = int64 Deriving_from_wildcard.opaque [@@deriving compare, quickcheck, sexp_of] let examples = Deriving_from_wildcard.opaque_examples end in test (module Opaque) (module Opaque); [%expect {| (generator "generated 4_207 distinct values in 10_000 iterations") (observer transparent) (shrinker (((0) => ()) ((1) => ()))) |}] ;; module Do_not_generate_clauses = Do_not_generate_clauses let%expect_test "variant with clauses excluded from generator" = let module Do_not_generate_clauses' = struct type t = Do_not_generate_clauses.t = | Can_generate of bool | Cannot_generate of Do_not_generate_clauses.Cannot_generate.t [@@deriving compare, enumerate, sexp_of] end in test ~generator:`inexhaustive (module Do_not_generate_clauses) (m_all (module Do_not_generate_clauses')); [%expect {| (generator ("generated 2 distinct values in 10_000 iterations" ("did not generate these values" ((Cannot_generate ()) (Cannot_generate (false)) (Cannot_generate (true)))))) (observer transparent) (shrinker (((Cannot_generate (false)) => (Cannot_generate ())) ((Cannot_generate (true)) => (Cannot_generate ())))) |}]; let module Poly' = struct type t = [ `Can_generate of bool | `Cannot_generate of Do_not_generate_clauses.Cannot_generate.t ] [@@deriving compare, enumerate, sexp_of] end in test ~generator:`inexhaustive (module Do_not_generate_clauses.Poly) (m_all (module Poly')); [%expect {| (generator ("generated 2 distinct values in 10_000 iterations" ("did not generate these values" ((Cannot_generate ()) (Cannot_generate (false)) (Cannot_generate (true)))))) (observer transparent) (shrinker (((Cannot_generate (false)) => (Cannot_generate ())) ((Cannot_generate (true)) => (Cannot_generate ())))) |}] ;; base_quickcheck-0.17.1/ppx_quickcheck/test/src/test_ppx_quickcheck.mli000066400000000000000000000001661501616613400262240ustar00rootroot00000000000000(* Make sure we test runtime behavior of all syntax examples. *) include module type of Ppx_quickcheck_test_examples base_quickcheck-0.17.1/ppx_quickcheck/test/toplevel/000077500000000000000000000000001501616613400225215ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/test/toplevel/dune000066400000000000000000000000001501616613400233650ustar00rootroot00000000000000base_quickcheck-0.17.1/ppx_quickcheck/test/toplevel/errors.mlt000066400000000000000000000047601501616613400245620ustar00rootroot00000000000000type abstract [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: abstract type |}] type gadt = GADT : 'a -> gadt [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: GADT |}] type variant_gt = [> `tag ] [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: polymorphic variant type with [>] |}] type variant_lt = [< `tag ] [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: polymorphic variant type with [<] |}] type record_mutable = { pure : [ `a | `b ] ; mutable impure : [ `a | `b ] } [@@deriving quickcheck] [%%expect {| |}] type ('a, 'b) fn = 'a -> 'b [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: invalid syntax: misuse of type variable 'a: would confuse observer with generator in generated code; could be due to a missing or incorrect covariance/contravariance annotation |}] let _ = [%quickcheck.generator: [%arbitrary.tag? ()]] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: unknown extension: arbitrary.tag |}] let _ = [%quickcheck.observer: [%custom 1;; 2]] ;; [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: invalid syntax: [%custom] extension expects a single expression as its payload |}] let _ = [%quickcheck.shrinker: unit * [%custom: bool] * char] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: invalid syntax: [%custom] extension expects a single expression as its payload |}] let _ = [%quickcheck.generator: _ list] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: unsupported: wildcard type |}] type t = | [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: invalid syntax: variant had no (generated) cases |}] type t = A [@quickcheck.do_not_generate] [@@deriving quickcheck] [%%expect {| Line _, characters _-_: Error: ppx_quickcheck: invalid syntax: variant had no (generated) cases |}] (* While the following might look like the above, there's an important distinction which is that to quickcheck, "0." is just an expression when doing the ppx expansion (as opposed to being a float). So, the following gives a runtime error where the above gives a compile-time error. *) type t = A [@quickcheck.weight 0.] [@@deriving quickcheck] [%%expect {| Exception: "Base_quickcheck.Generator.of_weighted_list: total weight is zero" |}] base_quickcheck-0.17.1/ppx_quickcheck/test/toplevel/should_succeed.mlt000066400000000000000000000020471501616613400262330ustar00rootroot00000000000000type 'a t = | Zero | Succ of 'a t [@@deriving quickcheck] [%%expect {| |}] module With_base_shadowed = struct module Base = struct end type t = | A | B [@@deriving quickcheck] end [%%expect {| |}] module With_base_quickcheck_shadowed = struct module Base_quickcheck = struct end type t = | X | Y [@@deriving quickcheck] end [%%expect {| |}] (* Make sure [@quickcheck.do_not_generate] works with recursive variant types. (There was formerly an issue with this.) *) type recursive_with_do_not_generate = | A | B of recursive_with_do_not_generate [@quickcheck.do_not_generate] [@@deriving quickcheck] [%%expect {| |}] type recursive_with_do_not_generate2 = | A | B [@quickcheck.do_not_generate] | C of recursive_with_do_not_generate2 [@@deriving quickcheck] [%%expect {| |}] module _ = struct open Base_quickcheck.Export type 'a polyvar_with_param = [ `A of 'a ] [@@deriving quickcheck] type inheriting_polyvar_with_param = [ | int polyvar_with_param ] [@@deriving quickcheck] end [%%expect {| |}] base_quickcheck-0.17.1/src/000077500000000000000000000000001501616613400154765ustar00rootroot00000000000000base_quickcheck-0.17.1/src/base_quickcheck.ml000066400000000000000000000005251501616613400211360ustar00rootroot00000000000000module Generator = Generator module Observer = Observer module Shrinker = Shrinker module Test = Test module Export = Export include Export (**/**) (*_ This module is exposed only to make ocamldoc output more readable. *) module With_basic_types = With_basic_types module Private = struct module Bigarray_helpers = Bigarray_helpers end base_quickcheck-0.17.1/src/bigarray_helpers.ml000066400000000000000000000046361501616613400213630ustar00rootroot00000000000000open! Base module Layout = struct type 'a t = 'a Bigarray.layout let offset : type a. a t -> int = function | Bigarray.Fortran_layout -> 1 | Bigarray.C_layout -> 0 ;; end module Array1 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array1.t let iteri t ~f = let offset = Layout.offset (Bigarray.Array1.layout t) in for i = 0 to Bigarray.Array1.dim t - 1 do f (i + offset) t.{i + offset} done ;; let init (type elt) (kind : (elt, _) Bigarray.kind) layout dim ~f = let t = Bigarray.Array1.create kind layout dim in iteri t ~f:(fun i (_ : elt) -> t.{i} <- f i); t ;; let fold (type elt) (t : (elt, _, _) t) ~init ~f = let init = ref init in iteri t ~f:(fun i (_ : elt) -> init := f !init t.{i}); !init ;; let to_array t = let offset = Layout.offset (Bigarray.Array1.layout t) in Array.init (Bigarray.Array1.dim t) ~f:(fun i -> t.{i + offset}) ;; let sexp_of_t sexp_of_elt _sexp_of_pack _sexp_of_layout t = [%sexp (to_array t : elt array)] ;; let hash_fold hash_fold_elt state t = let state = hash_fold_int state (Bigarray.Array1.dim t) in fold t ~init:state ~f:hash_fold_elt ;; end module Array2 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Bigarray.Array2.t let iteri t ~f = let offset = Layout.offset (Bigarray.Array2.layout t) in for i = 0 to Bigarray.Array2.dim1 t - 1 do for j = 0 to Bigarray.Array2.dim2 t - 1 do f (i + offset) (j + offset) t.{i + offset, j + offset} done done ;; let init (type elt) (kind : (elt, _) Bigarray.kind) layout dim1 dim2 ~f = let t = Bigarray.Array2.create kind layout dim1 dim2 in iteri t ~f:(fun i j (_ : elt) -> t.{i, j} <- f i j); t ;; let fold (type elt) (t : (elt, _, _) t) ~init ~f = let init = ref init in iteri t ~f:(fun (_ : int) (_ : int) elt -> init := f !init elt); !init ;; let to_array t = let offset = Layout.offset (Bigarray.Array2.layout t) in Array.init (Bigarray.Array2.dim1 t) ~f:(fun i -> Array.init (Bigarray.Array2.dim2 t) ~f:(fun j -> t.{i + offset, j + offset})) ;; let sexp_of_t sexp_of_elt _sexp_of_pack _sexp_of_layout t = [%sexp (to_array t : elt array array)] ;; let hash_fold hash_fold_elt state t = let state = hash_fold_int state (Bigarray.Array2.dim1 t) in let state = hash_fold_int state (Bigarray.Array2.dim2 t) in fold t ~init:state ~f:hash_fold_elt ;; end base_quickcheck-0.17.1/src/bigarray_helpers.mli000066400000000000000000000030471501616613400215270ustar00rootroot00000000000000open! Base (** Helpers for working with Bigarrays. These are not in [Base] because it's rare to work with bigarrays other than bigstring. We can move them into a separate library if there is demand. *) module Layout : sig type 'a t = 'a Bigarray.layout (** [offset t] is the index of the lowest-numbered element. *) val offset : _ t -> int end module Array1 : sig type ('elt, 'pack, 'layout) t = ('elt, 'pack, 'layout) Bigarray.Array1.t [@@deriving sexp_of] val init : ('elt, 'pack) Bigarray.kind -> 'layout Bigarray.layout -> int -> f:(int -> 'elt) -> ('elt, 'pack, 'layout) t val iteri : ('elt, _, _) t -> f:(int -> 'elt -> unit) -> unit val fold : ('elt, _, _) t -> init:'a -> f:('a -> 'elt -> 'a) -> 'a val to_array : ('elt, _, _) t -> 'elt array val hash_fold : (Hash.state -> 'elt -> Hash.state) -> Hash.state -> ('elt, _, _) t -> Hash.state end module Array2 : sig type ('elt, 'pack, 'layout) t = ('elt, 'pack, 'layout) Bigarray.Array2.t [@@deriving sexp_of] val init : ('elt, 'pack) Bigarray.kind -> 'layout Bigarray.layout -> int -> int -> f:(int -> int -> 'elt) -> ('elt, 'pack, 'layout) t val iteri : ('elt, _, _) t -> f:(int -> int -> 'elt -> unit) -> unit val fold : ('elt, _, _) t -> init:'a -> f:('a -> 'elt -> 'a) -> 'a (** The output matches the layout of the input. *) val to_array : ('elt, _, _) t -> 'elt array array val hash_fold : (Hash.state -> 'elt -> Hash.state) -> Hash.state -> ('elt, _, _) t -> Hash.state end base_quickcheck-0.17.1/src/dune000066400000000000000000000003151501616613400163530ustar00rootroot00000000000000(library (name base_quickcheck) (public_name base_quickcheck) (libraries base splittable_random) (preprocess (pps ppx_base ppx_fields_conv ppx_let ppx_sexp_message ppx_sexp_value))) (documentation) base_quickcheck-0.17.1/src/export.ml000066400000000000000000000041471501616613400173570ustar00rootroot00000000000000open! Base let quickcheck_generator_unit = Generator.unit let quickcheck_generator_bool = Generator.bool let quickcheck_generator_char = Generator.char let quickcheck_generator_string = Generator.string let quickcheck_generator_bytes = Generator.bytes let quickcheck_generator_int = Generator.int let quickcheck_generator_int32 = Generator.int32 let quickcheck_generator_int64 = Generator.int64 let quickcheck_generator_nativeint = Generator.nativeint let quickcheck_generator_float = Generator.float let quickcheck_generator_option = Generator.option let quickcheck_generator_list = Generator.list let quickcheck_generator_array = Generator.array let quickcheck_generator_ref = Generator.ref let quickcheck_generator_lazy_t = Generator.lazy_t let quickcheck_observer_unit = Observer.unit let quickcheck_observer_bool = Observer.bool let quickcheck_observer_char = Observer.char let quickcheck_observer_string = Observer.string let quickcheck_observer_bytes = Observer.bytes let quickcheck_observer_int = Observer.int let quickcheck_observer_int32 = Observer.int32 let quickcheck_observer_int64 = Observer.int64 let quickcheck_observer_nativeint = Observer.nativeint let quickcheck_observer_float = Observer.float let quickcheck_observer_option = Observer.option let quickcheck_observer_list = Observer.list let quickcheck_observer_array = Observer.array let quickcheck_observer_ref = Observer.ref let quickcheck_observer_lazy_t = Observer.lazy_t let quickcheck_shrinker_unit = Shrinker.unit let quickcheck_shrinker_bool = Shrinker.bool let quickcheck_shrinker_char = Shrinker.char let quickcheck_shrinker_string = Shrinker.string let quickcheck_shrinker_bytes = Shrinker.bytes let quickcheck_shrinker_int = Shrinker.int let quickcheck_shrinker_int32 = Shrinker.int32 let quickcheck_shrinker_int64 = Shrinker.int64 let quickcheck_shrinker_nativeint = Shrinker.nativeint let quickcheck_shrinker_float = Shrinker.float let quickcheck_shrinker_option = Shrinker.option let quickcheck_shrinker_list = Shrinker.list let quickcheck_shrinker_array = Shrinker.array let quickcheck_shrinker_ref = Shrinker.ref let quickcheck_shrinker_lazy_t = Shrinker.lazy_t base_quickcheck-0.17.1/src/export.mli000066400000000000000000000051631501616613400175270ustar00rootroot00000000000000(** Provides default generators, observers, and shrinkers for built-in types. Follows ppx_quickcheck naming conventions. *) open! Base val quickcheck_generator_unit : unit Generator.t val quickcheck_generator_bool : bool Generator.t val quickcheck_generator_char : char Generator.t val quickcheck_generator_string : string Generator.t val quickcheck_generator_bytes : bytes Generator.t val quickcheck_generator_int : int Generator.t val quickcheck_generator_int32 : int32 Generator.t val quickcheck_generator_int64 : int64 Generator.t val quickcheck_generator_nativeint : nativeint Generator.t val quickcheck_generator_float : float Generator.t val quickcheck_observer_unit : unit Observer.t val quickcheck_observer_bool : bool Observer.t val quickcheck_observer_char : char Observer.t val quickcheck_observer_string : string Observer.t val quickcheck_observer_bytes : bytes Observer.t val quickcheck_observer_int : int Observer.t val quickcheck_observer_int32 : int32 Observer.t val quickcheck_observer_int64 : int64 Observer.t val quickcheck_observer_nativeint : nativeint Observer.t val quickcheck_observer_float : float Observer.t val quickcheck_shrinker_unit : unit Shrinker.t val quickcheck_shrinker_bool : bool Shrinker.t val quickcheck_shrinker_char : char Shrinker.t val quickcheck_shrinker_string : string Shrinker.t val quickcheck_shrinker_bytes : bytes Shrinker.t val quickcheck_shrinker_int : int Shrinker.t val quickcheck_shrinker_int32 : int32 Shrinker.t val quickcheck_shrinker_int64 : int64 Shrinker.t val quickcheck_shrinker_nativeint : nativeint Shrinker.t val quickcheck_shrinker_float : float Shrinker.t val quickcheck_generator_option : 'a Generator.t -> 'a option Generator.t val quickcheck_generator_list : 'a Generator.t -> 'a list Generator.t val quickcheck_generator_array : 'a Generator.t -> 'a array Generator.t val quickcheck_generator_ref : 'a Generator.t -> 'a ref Generator.t val quickcheck_generator_lazy_t : 'a Generator.t -> 'a Lazy.t Generator.t val quickcheck_observer_option : 'a Observer.t -> 'a option Observer.t val quickcheck_observer_list : 'a Observer.t -> 'a list Observer.t val quickcheck_observer_array : 'a Observer.t -> 'a array Observer.t val quickcheck_observer_ref : 'a Observer.t -> 'a ref Observer.t val quickcheck_observer_lazy_t : 'a Observer.t -> 'a Lazy.t Observer.t val quickcheck_shrinker_option : 'a Shrinker.t -> 'a option Shrinker.t val quickcheck_shrinker_list : 'a Shrinker.t -> 'a list Shrinker.t val quickcheck_shrinker_array : 'a Shrinker.t -> 'a array Shrinker.t val quickcheck_shrinker_ref : 'a Shrinker.t -> 'a ref Shrinker.t val quickcheck_shrinker_lazy_t : 'a Shrinker.t -> 'a Lazy.t Shrinker.t base_quickcheck-0.17.1/src/generator.ml000066400000000000000000000643011501616613400200220ustar00rootroot00000000000000open! Base module T : sig type +'a t val create : (size:int -> random:Splittable_random.t -> 'a) -> 'a t val generate : 'a t -> size:int -> random:Splittable_random.t -> 'a end = struct type 'a t = (size:int -> random:Splittable_random.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.split random in fun x -> let hash = Observer0.observe dom x ~size ~hash:(Hash.alloc ()) in let random = Splittable_random.copy random in Splittable_random.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.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.t -> lo:t -> hi:t -> t val log_uniform : Splittable_random.t -> lo:t -> hi:t -> t end module For_integer (Integer : Int_with_random) = struct let geometric lo ~p = if Float.equal p 1. then return lo else if Float.equal p 0. then return Integer.max_value else if Float.( < ) p 0. || Float.( > ) p 1. || Float.is_nan p then raise_s [%message "geometric distribution: p must be between 0 and 1" (p : float)] else ( (* We start with a uniform distribution. We convert to exponential distribution using [log]. We convert to geometric with [round_down]. Then we bounds check and return. *) let denominator = Float.log1p (-.p) in create (fun ~size:_ ~random -> let uniform = Splittable_random.unit_float random in let exponential = Float.log uniform /. denominator in let float = Float.round_down exponential in match Integer.of_float float with | exception Invalid_argument _ -> Integer.max_value | int -> let int = Integer.( + ) lo int in if Integer.( < ) int lo then Integer.max_value else int)) ;; 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 let int_geometric = For_int.geometric 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 let int32_geometric = For_int32.geometric 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 let int63_geometric = For_int63.geometric 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 let int64_geometric = For_int64.geometric 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 nativeint_geometric = For_nativeint.geometric 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 module Edit_string = struct let edit_insert string = let%bind pos = int_uniform_inclusive 0 (String.length string) in let%bind len = int_geometric 1 ~p:0.5 in let%bind str = string_with_length ~length:len in [ String.prefix string pos; str; String.drop_prefix string pos ] |> String.concat |> return ;; let edit_remove string = let%bind len = int_log_uniform_inclusive 1 (String.length string) in let%bind pos = int_uniform_inclusive 0 (String.length string - len) in [ String.prefix string pos; String.drop_prefix string (pos + len) ] |> String.concat |> return ;; let edit_replace string = let%bind len = int_log_uniform_inclusive 1 (String.length string) in let%bind pos = int_uniform_inclusive 0 (String.length string - len) in let%bind str = string_with_length ~length:len in [ String.prefix string pos; str; String.drop_prefix string (pos + len) ] |> String.concat |> return ;; let edit_double string = let%bind len = int_log_uniform_inclusive 1 (String.length string) in let%bind pos = int_uniform_inclusive 0 (String.length string - len) in [ String.prefix string (pos + len); String.drop_prefix string pos ] |> String.concat |> return ;; let edit_nonempty string = [ edit_insert string; edit_remove string; edit_replace string; edit_double string ] |> union ;; let rec edit string n_times = if n_times <= 0 then return string else ( let%bind string = if String.is_empty string then edit_insert string else edit_nonempty string in edit string (n_times - 1)) ;; end let string_like string = let%bind n_times = int_geometric 0 ~p:0.5 in Edit_string.edit string n_times ;; 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 ~length = let%map elts = match length with | None -> list t | Some length -> list_with_length t ~length 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_gen = bigarray1 char Char C_layout let float32_vec_gen = bigarray1 float Float32 Fortran_layout let float64_vec_gen = bigarray1 float Float64 Fortran_layout let bigstring = bigstring_gen ~length:None let float32_vec = float32_vec_gen ~length:None let float64_vec = float64_vec_gen ~length:None let bigstring_with_length ~length = bigstring_gen ~length:(Some length) let float32_vec_with_length ~length = float32_vec_gen ~length:(Some length) let float64_vec_with_length ~length = float64_vec_gen ~length:(Some length) 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 base_quickcheck-0.17.1/src/generator.mli000066400000000000000000000364461501616613400202040ustar00rootroot00000000000000(** Generators are sources of random values. Every randomized test needs a generator to produce its inputs. *) open! Base type +'a t (** {2 Basic Generators} These are good default generators for tests over types from OCaml and Base. They are designed to hit corner cases reasonably often, and also generate reasonably good coverage of common cases and arbitrary values. *) include With_basic_types.S with type 'a t := 'a t (** @inline *) (** Generates random functions that use the given observer to perturb the pseudo-random state that is then used to generate the output value. The resulting functions are therefore deterministic, assuming the observer is deterministic. *) val fn : 'a Observer0.t -> 'b t -> ('a -> 'b) t val map_t_m : ('key, 'cmp) Comparator.Module.t -> 'key t -> 'data t -> ('key, 'data, 'cmp) Map.t t val set_t_m : ('elt, 'cmp) Comparator.Module.t -> 'elt t -> ('elt, 'cmp) Set.t t val map_tree_using_comparator : comparator:('key, 'cmp) Comparator.t -> 'key t -> 'data t -> ('key, 'data, 'cmp) Map.Using_comparator.Tree.t t val set_tree_using_comparator : comparator:('elt, 'cmp) Comparator.t -> 'elt t -> ('elt, 'cmp) Set.Using_comparator.Tree.t t (** {2 Combining and Modifying Generators} *) (** Produces any of the given values, weighted uniformly. *) val of_list : 'a list -> 'a t (** Chooses among the given generators, weighted uniformly; then chooses a value from that generator. *) val union : 'a t list -> 'a t include Applicative.S with type 'a t := 'a t include Monad.S with type 'a t := 'a t (** {2 Size of Random Values} Base_quickcheck threads a size parameter through generators to limit the size of unbounded types. Users of Base_quickcheck often do not need to think about the size parameter; the default generators handle it sensibly. Generators of atomic types ignore it, generators of bounded-size containers like [both] and [either] thread it through unchanged, and generators of unbounded-size containers like [list] and [set_t_m] distribute the size they are given among their constituents. The bindings below allow direct manipulation of the size parameter in cases where users want a custom treatment of sizes. There is no prescribed meaning of the size parameter for any given type other than that it must be non-negative. As a general guideline, however, the time and space used to generate a value should be proportional to the size parameter at most. The size parameter should be treated as an upper bound but not as a lower bound, so for example a generator given a size parameter of 2 should have a chance to generate values of size 0 or 1 as well. If the size parameter is treated as a lower bound, then for example members of tuples will always be generated at the same size, and test cases for members of different size will not be covered. *) (** Returns the current size parameter. *) val size : int t (** Produces a generator that ignores the size parameter passed in by Base_quickcheck and instead uses the given [~size] argument. Most often used with [size] to reduce the size when dispatching to generators for subparts of a value. For example, here is a use of [with_size] and [size] to create a generator for optional lists. We are careful to generate [None] even at non-zero sizes; see the note above about not using [size] as a lower bound. {[ let optional_list generator = let open Let_syntax in match%bind both size bool with | (0, _) | (_, false) -> return None | k, _ -> let%map elements = with_size ~size:(k-1) (list generator) in Some elements ]} *) val with_size : 'a t -> size:int -> 'a t (** Produces a list of sizes that distribute the current size among list elements. The [min_length] and [max_length] parameters can be used to bound the length of the result. This is the distribution used by generators such as [list] to divide up size among elements. This function is designed so that elements of [list] are always generated at strictly smaller size than the list itself. The technical invariant is: if [size_list] is generated by [with_size ~size:n (sizes ~min_length ())], then: {[ (List.length size_list - min_length) + (List.sum (module Int) size_list) <= n ]} *) val sizes : ?min_length:int -> ?max_length:int -> unit -> int list t (** {2 Filtering Generators} *) (** Produces values for which [f] returns [true]. If [f] returns [false], retries with [size] incremented by 1. This avoids [filter] getting stuck if all values at a given size fail [f]; see the note above about not using [size] as a lower bound. *) val filter : 'a t -> f:('a -> bool) -> 'a t (** When [f] produces [Some x], produces [x]. If [f] returns [None], retries with [size] incremented by 1, as with [filter]. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** {2 Generating Recursive Values} *) (** Ties the recursive knot to produce generators for recursive types that have multiple clauses, separating base cases from recursive cases. At size 0, only base cases are produced; at size [n > 0], the base cases are produced at size [n] along with the recursive cases at size [n-1]. Raises if the list of base cases is empty or if the list of recursive cases is empty. For example, here is a use of [recursive_union] to create a generator for an expression datatype. {[ type exp = | Int of int | Bool of bool | If of exp * exp * exp | Add of exp * exp let exp_generator = recursive_union [ map int ~f:(fun i -> Int i); map bool ~f:(fun b -> Bool b); ] ~f:(fun exp -> let open Let_syntax in [ (let%map a = exp and b = exp and c = exp in If (a, b, c)); (let%map a = exp and b = exp in Add (a, b)); ]) ]} *) val recursive_union : 'a t list -> f:('a t -> 'a t list) -> 'a t (** Like [recursive_union], without separate clauses or automatic size management. Useful for generating recursive types that don't fit the clause structure of [recursive_union]. For example, here is a use of [fixed_point] to create a generator for N-ary trees. No manual size management is needed, as [Generator.list] guarantees to generate list elements at strictly smaller sizes than the list itself. {[ type tree = Node of tree list let tree_generator = fixed_point (fun tree -> map (list tree) ~f:(fun trees -> Node trees)) ]} *) val fixed_point : ('a t -> 'a t) -> 'a t (** Creates a [t] that forces the lazy argument as necessary. Can be used to tie (mutually) recursive knots. *) val of_lazy : 'a t Lazy.t -> 'a t (** {2 Custom Random Distributions} *) (** Produces one of the given values, chosen with the corresponding weight. Weights must be non-negative and must have a strictly positive sum. *) val of_weighted_list : (float * 'a) list -> 'a t (** Produces one of the given generators, chosen with the corresponding weight, then chooses a value from that generator. Weights must be non-negative and must have a strictly positive sum. *) val weighted_union : (float * 'a t) list -> 'a t (** Like [recursive_union], with explicit weights for each clause. Weights must be non-negative and the recursive case weights must have a strictly positive sum. *) val weighted_recursive_union : (float * 'a t) list -> f:('a t -> (float * 'a t) list) -> 'a t (** {3 Integer Distributions} *) (** Produces an integer between 0 and an unspecified upper bound which is proportional to [size]. This is a good generator to use for sizes of values like strings which have a variable number of fixed-size elements. *) val small_positive_or_zero_int : int t (** Like [small_positive_or_zero_int] but with a minimum of [1]. *) val small_strictly_positive_int : int t (** {4 Uniform Unbounded Distributions} These generators produce any value of the relevant integer type with uniform weight. The default generators for these types differ in that they give higher weight to corner cases, e.g. [min_value] and [max_value]. *) val int_uniform : int t val int32_uniform : int32 t val int63_uniform : Int63.t t val int64_uniform : int64 t val nativeint_uniform : nativeint t (** {4 Bounded Distributions} These generators produce any value between the given inclusive bounds, which must be given in nondecreasing order. Higher weight is given to corner cases, e.g. the bounds themselves. *) val int_inclusive : int -> int -> int t val int32_inclusive : int32 -> int32 -> int32 t val int63_inclusive : Int63.t -> Int63.t -> Int63.t t val int64_inclusive : int64 -> int64 -> int64 t val nativeint_inclusive : nativeint -> nativeint -> nativeint t (** {4 Uniform Bounded Distributions} These generators produce any value between the given inclusive bounds, which must be given in nondecreasing order. All values are given equal weight. *) val int_uniform_inclusive : int -> int -> int t val int32_uniform_inclusive : int32 -> int32 -> int32 t val int63_uniform_inclusive : Int63.t -> Int63.t -> Int63.t t val int64_uniform_inclusive : int64 -> int64 -> int64 t val nativeint_uniform_inclusive : nativeint -> nativeint -> nativeint t (** {4 Uniform in Log Space Distributions} These generators produce any value between the given inclusive, non-negative bounds, choosing bit-length in that range uniformly and then uniformly among values with that bit-length between the bounds. The bounds must be given in nondecreasing order. *) val int_log_uniform_inclusive : int -> int -> int t val int32_log_uniform_inclusive : int32 -> int32 -> int32 t val int63_log_uniform_inclusive : Int63.t -> Int63.t -> Int63.t t val int64_log_uniform_inclusive : int64 -> int64 -> int64 t val nativeint_log_uniform_inclusive : nativeint -> nativeint -> nativeint t (** {4 Log Space Distributions} Like the [*_log_uniform_inclusive] bindings above, but giving additional weight to corner cases, e.g. the given bounds. *) val int_log_inclusive : int -> int -> int t val int32_log_inclusive : int32 -> int32 -> int32 t val int63_log_inclusive : Int63.t -> Int63.t -> Int63.t t val int64_log_inclusive : int64 -> int64 -> int64 t val nativeint_log_inclusive : nativeint -> nativeint -> nativeint t (** {4 Geometric Distributions} These generators produce a geometric distribution with a given minimum and probabilty [p]. In other words, with probability [p], the minimum is produced. Otherwise, a value is effectively produced from a geometric distribution with the same [p] and a minimum one higher, although the implementation can be more efficent than this. If the result overflows, the function returns [max_value] for the integer type. Raises if [p <. 0. || 1. <. p.]. *) val int_geometric : int -> p:float -> int t val int32_geometric : int32 -> p:float -> int32 t val int63_geometric : Int63.t -> p:float -> Int63.t t val int64_geometric : int64 -> p:float -> int64 t val nativeint_geometric : nativeint -> p:float -> nativeint t (** {3 Floating Point Distributions} *) (** Generates values between the given bounds, inclusive, which must be finite and in nondecreasing order. Weighted toward boundary values. *) val float_inclusive : float -> float -> float t (** Generates values between the given bounds, exclusive, which must be finite and in increasing order, with at least one float value between them. Weighted approximately uniformly across the resulting range, rounding error notwithstanding. *) val float_uniform_exclusive : float -> float -> float t val float_without_nan : float t val float_finite : float t val float_strictly_positive : float t val float_strictly_negative : float t val float_positive_or_zero : float t val float_negative_or_zero : float t val float_of_class : Float.Class.t -> float t (** {3 Character Distributions} *) val char_lowercase : char t val char_uppercase : char t val char_digit : char t val char_alpha : char t val char_alphanum : char t val char_whitespace : char t val char_print : char t val char_uniform_inclusive : char -> char -> char t (** {3 String Distributions} *) val string_non_empty : string t val string_with_length : length:int -> string t val string_of : char t -> string t val string_non_empty_of : char t -> string t val string_with_length_of : char t -> length:int -> string t (** Produces strings similar to the input, with some number of edits. *) val string_like : string -> string t (** {3 Sexp Distributions} *) (** Produces s-expressions whose atoms are chosen from the given string distribution. *) val sexp_of : string t -> Sexp.t t (** {3 List Distributions} *) val list_non_empty : 'a t -> 'a list t val list_with_length : 'a t -> length:int -> 'a list t (** Randomly drops elements from a list. The length of each result is chosen uniformly between 0 and the length of the input, inclusive. *) val list_filtered : 'a list -> 'a list t (** Produces permutations of the given list, weighted uniformly. *) val list_permutations : 'a list -> 'a list t (** {3 Bigarray Distributions} *) include sig open Bigarray val bigarray1 : 'a t -> ('a, 'b) kind -> 'c layout -> length:int option -> ('a, 'b, 'c) Array1.t t val bigstring_with_length : length:int -> (char, int8_unsigned_elt, c_layout) Array1.t t val float32_vec_with_length : length:int -> (float, float32_elt, fortran_layout) Array1.t t val float64_vec_with_length : length:int -> (float, float64_elt, fortran_layout) Array1.t t end (** @inline *) (** {2 Low-Level Interface} These functions provide direct access to the pseudo-random state threaded through Base_quickcheck generators. Most users should not need these functions. *) (** Passes in additional "salt" used to perturb the pseudo-random state used to generate random values. Generators' output is intended to be deterministic for any initial pseudorandom state, so [perturb] can be used to generate a new generator with the same distribution that nonetheless produces different values from the original for any given pseudo-random state. *) val perturb : 'a t -> int -> 'a t (** Creates a generator that calls the given function with the current size parameter and pseudorandom state. *) val create : (size:int -> random:Splittable_random.t -> 'a) -> 'a t (** Generates a random value using the given size and pseudorandom state. Useful when using [create] and dispatching to other existing generators. *) val generate : 'a t -> size:int -> random:Splittable_random.t -> 'a module Debug : sig (** {3 Helpers for debugging generators} *) (** [coverage (module Key) sample] counts how many times each key appears in [sample]. See [Test.with_sample] for a convenient way to generate [sample]. *) val coverage : (module Comparator.S with type t = 'k and type comparator_witness = 'cmp) -> 'k Sequence.t -> ('k, int, 'cmp) Map.t (** [monitor t ~f] returns a generator which gives the same values as [t] and also calls [f] for each value. This can help diagnose behavior of generators "hidden" behind [map], [filter], etc. One might count the number of values a generator produces, or record the set of values that do not satisfy some filter. *) val monitor : 'a t -> f:('a -> unit) -> 'a t end base_quickcheck-0.17.1/src/index.mld000066400000000000000000000002531501616613400173030ustar00rootroot00000000000000{0 Base_quickcheck} Base_quickcheck is a randomized testing framework for OCaml, designed for users of {!Base}. {b {{!Base_quickcheck} The full API is browsable here.}} base_quickcheck-0.17.1/src/observer.ml000066400000000000000000000064411501616613400176640ustar00rootroot00000000000000open! Base include Observer0 let unmap t ~f = create (fun x ~size ~hash -> observe t (f x) ~size ~hash) let of_hash_fold f = create (fun x ~size:_ ~hash -> f hash x) let of_lazy lazy_t = create (fun x ~size ~hash -> observe (force lazy_t) x ~size ~hash) let fixed_point wrap = let rec lazy_t = lazy (wrap (of_lazy lazy_t)) in of_lazy lazy_t ;; let unit = opaque let bool = of_hash_fold Bool.hash_fold_t let char = of_hash_fold Char.hash_fold_t let int = of_hash_fold Int.hash_fold_t let int32 = of_hash_fold Int32.hash_fold_t let int63 = of_hash_fold Int63.hash_fold_t let int64 = of_hash_fold Int64.hash_fold_t let nativeint = of_hash_fold Nativeint.hash_fold_t let float = of_hash_fold Float.hash_fold_t let string = of_hash_fold String.hash_fold_t let sexp = of_hash_fold Sexp.hash_fold_t let bigstring = of_hash_fold (Bigarray_helpers.Array1.hash_fold hash_fold_char) let float32_vec = of_hash_fold (Bigarray_helpers.Array1.hash_fold hash_fold_float) let float64_vec = of_hash_fold (Bigarray_helpers.Array1.hash_fold hash_fold_float) let float32_mat = of_hash_fold (Bigarray_helpers.Array2.hash_fold hash_fold_float) let float64_mat = of_hash_fold (Bigarray_helpers.Array2.hash_fold hash_fold_float) let bytes = unmap string ~f:Bytes.to_string let either fst_t snd_t = create (fun either ~size ~hash -> match (either : _ Either.t) with | First fst -> observe fst_t fst ~size ~hash:(hash_fold_int hash 1) | Second snd -> observe snd_t snd ~size ~hash:(hash_fold_int hash 2)) ;; let result ok_t err_t = unmap (either ok_t err_t) ~f:(function | Ok ok -> First ok | Error err -> Second err) ;; let both fst_t snd_t = create (fun (fst, snd) ~size ~hash -> let hash = observe fst_t fst ~size ~hash in let hash = observe snd_t snd ~size ~hash in hash) ;; let option value_t = unmap (either opaque value_t) ~f:(function | None -> First () | Some value -> Second value) ;; let list elt_t = create (fun list ~size ~hash -> let random = Splittable_random.of_int (Hash.get_hash_value hash) in let length = List.length list in let sizes = Generator.sizes ~min_length:length ~max_length:length () |> Generator.generate ~size ~random in List.fold2_exn list sizes ~init:(hash_fold_int hash 0) ~f:(fun hash elt size -> observe elt_t elt ~size ~hash:(hash_fold_int hash 1))) ;; let array t = unmap (list t) ~f:Array.to_list let ref t = unmap t ~f:Ref.( ! ) let lazy_t t = unmap t ~f:Lazy.force let fn dom rng = create (fun f ~size ~hash -> let random = Splittable_random.of_int (Hash.get_hash_value hash) in let sizes = (* Empirically, doubling the size when generating the list of inputs gives us much better coverage of the space of functions. *) Generator.generate (Generator.sizes ()) ~size:(size * 2) ~random in List.fold sizes ~init:hash ~f:(fun hash size -> let x = Generator.generate dom ~size ~random in observe rng (f x) ~size ~hash)) ;; let map_tree key_obs data_obs = unmap (list (both key_obs data_obs)) ~f:Map.Using_comparator.Tree.to_alist ;; let set_tree elt_obs = unmap (list elt_obs) ~f:Set.Using_comparator.Tree.to_list let map_t key_obs data_obs = unmap (map_tree key_obs data_obs) ~f:Map.Using_comparator.to_tree ;; let set_t elt_obs = unmap (set_tree elt_obs) ~f:Set.Using_comparator.to_tree base_quickcheck-0.17.1/src/observer.mli000066400000000000000000000041031501616613400200260ustar00rootroot00000000000000(** Observers create random functions. {!Generator.fn} creates a random function using an observer for the input type and a generator for the output type. *) open! Base type -'a t = 'a Observer0.t (** {2 Basic Observers} *) (** Produces an observer that treats all values as equivalent. Random functions generated using this observer will be constant with respect to the value(s) it observes. *) val opaque : _ t include With_basic_types.S with type 'a t := 'a t (** @inline *) (** Produces an observer that generates random inputs for a given function, calls the function on them, then observes the corresponding outputs. *) val fn : 'a Generator.t -> 'b t -> ('a -> 'b) t val map_t : 'key t -> 'data t -> ('key, 'data, 'cmp) Map.t t val set_t : 'elt t -> ('elt, 'cmp) Set.t t val map_tree : 'key t -> 'data t -> ('key, 'data, 'cmp) Map.Using_comparator.Tree.t t val set_tree : 'elt t -> ('elt, 'cmp) Set.Using_comparator.Tree.t t (** {2 Observers Based on Hash Functions} *) (** Creates an observer that just calls a hash function. This is a good default for most hashable types not covered by the basic observers above. *) val of_hash_fold : (Hash.state -> 'a -> Hash.state) -> 'a t (** {2 Modifying Observers} *) val unmap : 'a t -> f:('b -> 'a) -> 'b t (** {2 Observers for Recursive Types} *) (** Ties the recursive knot to observe recursive types. For example, here is an observer for binary trees: {[ let tree_observer leaf_observer = fixed_point (fun self -> either leaf_observer (both self self) |> unmap ~f:(function | `Leaf leaf -> First leaf | `Node (l, r) -> Second (l, r))) ]} *) val fixed_point : ('a t -> 'a t) -> 'a t (** Creates a [t] that forces the lazy argument as necessary. Can be used to tie (mutually) recursive knots. *) val of_lazy : 'a t Lazy.t -> 'a t (** {2 Low-Level functions} Most users do not need to call these functions. *) val create : ('a -> size:int -> hash:Hash.state -> Hash.state) -> 'a t val observe : 'a t -> 'a -> size:int -> hash:Hash.state -> Hash.state base_quickcheck-0.17.1/src/observer0.ml000066400000000000000000000004461501616613400177430ustar00rootroot00000000000000open! Base type 'a t = 'a -> size:int -> hash:Hash.state -> Hash.state let create f : _ t = f let observe (t : _ t) x ~size ~hash = if size < 0 then raise_s [%message "Base_quickcheck.Observer.observe: size < 0" (size : int)] else t x ~size ~hash ;; let opaque _ ~size:_ ~hash = hash base_quickcheck-0.17.1/src/observer0.mli000066400000000000000000000002661501616613400201140ustar00rootroot00000000000000open! Base type -'a t val opaque : _ t val create : ('a -> size:int -> hash:Hash.state -> Hash.state) -> 'a t val observe : 'a t -> 'a -> size:int -> hash:Hash.state -> Hash.state base_quickcheck-0.17.1/src/shrinker.ml000066400000000000000000000154501501616613400176620ustar00rootroot00000000000000open! Base module T : sig type 'a t val atomic : _ t val create : ('a -> 'a Sequence.t) -> 'a t val shrink : 'a t -> 'a -> 'a Sequence.t end = struct type 'a t = 'a -> 'a Sequence.t let atomic _ = Sequence.empty let create = Fn.id let shrink = Fn.id end include T let map t ~f ~f_inverse = create (fun x -> Sequence.map ~f (shrink t (f_inverse x))) let filter t ~f = create (fun x -> Sequence.filter ~f (shrink t x)) let filter_map t ~f ~f_inverse = create (fun x -> Sequence.filter_map ~f (shrink t (f_inverse x))) ;; let of_lazy lazy_t = create (fun x -> Sequence.of_lazy (lazy (shrink (force lazy_t) x))) let fixed_point of_shrinker = let rec lazy_t = lazy (of_shrinker (of_lazy lazy_t)) in of_lazy lazy_t ;; let both fst_t snd_t = create (fun (fst, snd) -> Sequence.round_robin [ Sequence.map (shrink fst_t fst) ~f:(fun fst -> fst, snd) ; Sequence.map (shrink snd_t snd) ~f:(fun snd -> fst, snd) ]) ;; let unit = atomic let bool = atomic let char = atomic let int = atomic let int32 = atomic let int63 = atomic let int64 = atomic let nativeint = atomic let float = atomic let bigarray1 src = let dim = Bigarray.Array1.dim src in match dim with | 0 -> Sequence.empty | _ -> let kind = Bigarray.Array1.kind src in let layout = Bigarray.Array1.layout src in let offset = Bigarray_helpers.Layout.offset layout in Sequence.init dim ~f:(fun to_skip -> let to_skip = to_skip + offset in Bigarray_helpers.Array1.init kind layout (dim - 1) ~f:(fun i -> src.{if i < to_skip then i else i + 1})) ;; let bigstring = create bigarray1 let float32_vec = create bigarray1 let float64_vec = create bigarray1 let bigarray2 = let module Dims = struct type t = { dim1 : int ; dim2 : int } [@@deriving fields ~fields] let create a = Bigarray.Array2.{ dim1 = dim1 a; dim2 = dim2 a } end in let shrink field src = let dims = Dims.create src in match Field.get field dims with | 0 -> Sequence.empty | _ -> let kind = Bigarray.Array2.kind src in let layout = Bigarray.Array2.layout src in let offset = Bigarray_helpers.Layout.offset layout in let ({ dim1; dim2 } : Dims.t) = Field.map field dims ~f:Int.pred in Sequence.init (Field.get field dims) ~f:(fun to_skip -> let to_skip = to_skip + offset in let skip i = if i < to_skip then i else i + 1 in Bigarray_helpers.Array2.init kind layout dim1 dim2 ~f:(fun dim1 dim2 -> let ({ dim1; dim2 } : Dims.t) = Field.map field { dim1; dim2 } ~f:skip in src.{dim1, dim2})) in fun src -> Sequence.round_robin [ shrink Dims.Fields.dim1 src; shrink Dims.Fields.dim2 src ] ;; let float32_mat = create bigarray2 let float64_mat = create bigarray2 let option value_t = create (function | None -> Sequence.empty | Some value -> Sequence.append (Sequence.singleton None) (Sequence.map ~f:Option.return (shrink value_t value))) ;; let list elt_t = fixed_point (fun list_t -> create (function | [] -> Sequence.empty | head :: tail -> Sequence.round_robin [ Sequence.singleton tail ; Sequence.map (shrink elt_t head) ~f:(fun head -> head :: tail) ; Sequence.map (shrink list_t tail) ~f:(fun tail -> head :: tail) ])) ;; let string = map (list char) ~f:String.of_char_list ~f_inverse:String.to_list let bytes = map string ~f:Bytes.of_string ~f_inverse:Bytes.to_string let array t = map (list t) ~f:Array.of_list ~f_inverse:Array.to_list let ref t = map t ~f:Ref.create ~f_inverse:Ref.( ! ) let lazy_t t = map t ~f:Lazy.from_val ~f_inverse:Lazy.force let sexp = fixed_point (fun shrinker -> create (function | Sexp.Atom _ -> Sequence.empty | Sexp.List l -> let shrink_list = shrink (list shrinker) l |> Sequence.map ~f:(fun l -> Sexp.List l) in let shrink_tree = Sequence.of_list l in Sequence.round_robin [ shrink_list; shrink_tree ])) ;; let either fst_t snd_t = create (fun either -> match (either : _ Either.t) with | First fst -> Sequence.map (shrink fst_t fst) ~f:Either.first | Second snd -> Sequence.map (shrink snd_t snd) ~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) ~f_inverse:(function | Ok ok -> First ok | Error err -> Second err) ;; let map_tree_using_comparator ~comparator key_t data_t = create (fun tree -> let alist = Map.Using_comparator.Tree.to_alist tree in let drop_keys = Sequence.map (Sequence.of_list alist) ~f:(fun (k, _) -> Map.Using_comparator.Tree.remove ~comparator tree k) in let shrink_keys = Sequence.round_robin (List.map alist ~f:(fun (key, data) -> let tree = Map.Using_comparator.Tree.remove ~comparator tree key in Sequence.filter_map (shrink key_t key) ~f:(fun smaller_key -> match Map.Using_comparator.Tree.add ~comparator tree ~key:smaller_key ~data with | `Ok tree -> Some tree | `Duplicate -> None))) in let shrink_data = Sequence.round_robin (List.map alist ~f:(fun (key, data) -> Sequence.map (shrink data_t data) ~f:(fun smaller_data -> Map.Using_comparator.Tree.set ~comparator tree ~key ~data:smaller_data))) in Sequence.round_robin [ drop_keys; shrink_keys; shrink_data ]) ;; let set_tree_using_comparator ~comparator elt_t = create (fun tree -> let list = Set.Using_comparator.Tree.to_list tree in let drop_elts = Sequence.map (Sequence.of_list list) ~f:(fun elt -> Set.Using_comparator.Tree.remove ~comparator tree elt) in let shrink_elts = Sequence.round_robin (List.map list ~f:(fun elt -> let tree = Set.Using_comparator.Tree.remove ~comparator tree elt in Sequence.filter_map (shrink elt_t elt) ~f:(fun smaller_elt -> match Set.Using_comparator.Tree.mem ~comparator tree smaller_elt with | true -> None | false -> Some (Set.Using_comparator.Tree.add tree ~comparator smaller_elt)))) in Sequence.round_robin [ drop_elts; shrink_elts ]) ;; let map_t key_t data_t = create (fun map_t -> let comparator = Map.comparator map_t in let t = map (map_tree_using_comparator ~comparator key_t data_t) ~f:(Map.Using_comparator.of_tree ~comparator) ~f_inverse:Map.Using_comparator.to_tree in shrink t map_t) ;; let set_t elt_t = create (fun set_t -> let comparator = Set.comparator set_t in let t = map (set_tree_using_comparator ~comparator elt_t) ~f:(Set.Using_comparator.of_tree ~comparator) ~f_inverse:Set.Using_comparator.to_tree in shrink t set_t) ;; base_quickcheck-0.17.1/src/shrinker.mli000066400000000000000000000037721501616613400200370ustar00rootroot00000000000000(** Shrinkers produce small values from large values. When a random test case fails, a shrinker finds the simplest version of the problem. *) open! Base type 'a t (** {2 Basic Shrinkers} *) (** This shrinker treats a type as atomic, never attempting to produce smaller values. *) val atomic : _ t include With_basic_types.S with type 'a t := 'a t (** @inline *) val map_t : 'key t -> 'data t -> ('key, 'data, 'cmp) Map.t t val set_t : 'elt t -> ('elt, 'cmp) Set.t t val map_tree_using_comparator : comparator:('key, 'cmp) Comparator.t -> 'key t -> 'data t -> ('key, 'data, 'cmp) Map.Using_comparator.Tree.t t val set_tree_using_comparator : comparator:('elt, 'cmp) Comparator.t -> 'elt t -> ('elt, 'cmp) Set.Using_comparator.Tree.t t (** {2 Modifying Shrinkers} *) val map : 'a t -> f:('a -> 'b) -> f_inverse:('b -> 'a) -> 'b t val filter : 'a t -> f:('a -> bool) -> 'a t (** Filters and maps according to [f], and provides input to [t] via [f_inverse]. Only the [f] direction produces options, intentionally. *) val filter_map : 'a t -> f:('a -> 'b option) -> f_inverse:('b -> 'a) -> 'b t (** {2 Shrinkers for Recursive Types} *) (** Ties the recursive knot to shrink recursive types. For example, here is an shrinker for binary trees: {[ let tree_shrinker leaf_shrinker = fixed_point (fun self -> either leaf_shrinker (both self self) |> map ~f:(function | First leaf -> `Leaf leaf | Second (l, r) -> `Node (l, r)) ~f_inverse:(function | `Leaf leaf -> First leaf | `Node (l, r) -> Second (l, r))) ]} *) val fixed_point : ('a t -> 'a t) -> 'a t (** Creates a [t] that forces the lazy argument as necessary. Can be used to tie (mutually) recursive knots. *) val of_lazy : 'a t Lazy.t -> 'a t (** {2 Low-level functions} Most users will not need to call these. *) val create : ('a -> 'a Sequence.t) -> 'a t val shrink : 'a t -> 'a -> 'a Sequence.t base_quickcheck-0.17.1/src/test.ml000066400000000000000000000111741501616613400170130ustar00rootroot00000000000000open! Base include Test_intf module Config = struct module Seed = struct type t = | Nondeterministic | Deterministic of string [@@deriving sexp_of] end module Potentially_infinite_sequence = struct type 'a t = 'a Sequence.t let sexp_of_t sexp_of_elt sequence = let prefix, suffix = Sequence.split_n sequence 100 in let prefix = List.map prefix ~f:sexp_of_elt in let suffix = match Sequence.is_empty suffix with | true -> [] | false -> [ [%message "..."] ] in Sexp.List (prefix @ suffix) ;; end type t = { seed : Seed.t ; test_count : int ; shrink_count : int ; sizes : int Potentially_infinite_sequence.t } [@@deriving fields ~getters, sexp_of] end let default_config : Config.t = { seed = Deterministic "an arbitrary but deterministic string" ; test_count = (* [Splittable_random] is based on 64-bit arithmetic, and so tests run much slower on 32-bit targets. We run an order of magnitude fewer trials so as not to completely bog down continuous integration systems. *) (match Word_size.word_size with | W64 -> 10_000 | W32 -> 1_000) ; shrink_count = 10_000 ; sizes = Sequence.cycle_list_exn (List.range 0 ~start:`inclusive 30 ~stop:`inclusive) } ;; let lazy_nondeterministic_state = lazy (Random.State.make_self_init ()) let initial_random_state ~config = match Config.seed config with | Nondeterministic -> Splittable_random.create (force lazy_nondeterministic_state) | Deterministic string -> Splittable_random.of_int (String.hash string) ;; let one_size_per_test ~(config : Config.t) = Sequence.unfold ~init:(config.sizes, 0) ~f:(fun (sizes, number_of_size_values) -> match number_of_size_values >= config.test_count with | true -> None | false -> (match Sequence.next sizes with | Some (size, remaining_sizes) -> Some (size, (remaining_sizes, number_of_size_values + 1)) | None -> raise_s [%message "Base_quickcheck.Test.run: insufficient size values for test count" ~test_count:(config.test_count : int) (number_of_size_values : int)])) ;; let shrink_error ~shrinker ~config ~f input error = let rec loop ~shrink_count ~alternates input error = match shrink_count with | 0 -> input, error | _ -> let shrink_count = shrink_count - 1 in (match Sequence.next alternates with | None -> input, error | Some (alternate, alternates) -> (match f alternate with | Ok () -> loop ~shrink_count ~alternates input error | Error error -> let alternates = Shrinker.shrink shrinker alternate in loop ~shrink_count ~alternates alternate error)) in let shrink_count = Config.shrink_count config in let alternates = Shrinker.shrink shrinker input in loop ~shrink_count ~alternates input error ;; let input_sequence ~config ~examples ~generator = let random = initial_random_state ~config in Sequence.append (Sequence.of_list examples) (one_size_per_test ~config |> Sequence.map ~f:(fun size -> Generator.generate generator ~size ~random)) ;; let with_sample ~f ?(config = default_config) ?(examples = []) generator = let sequence = input_sequence ~config ~examples ~generator in f sequence ;; let result (type a) ~f ?(config = default_config) ?(examples = []) m = let (module M : S with type t = a) = m in with_sample M.quickcheck_generator ~config ~examples ~f:(fun sequence -> match Sequence.fold_result sequence ~init:() ~f:(fun () input -> match f input with | Ok () -> Ok () | Error error -> Error (input, error)) with | Ok () -> Ok () | Error (input, error) -> let shrinker = M.quickcheck_shrinker in let input, error = shrink_error ~shrinker ~config ~f input error in Error (input, error)) ;; let run (type a) ~f ?config ?examples (module M : S with type t = a) = let f x = Or_error.try_with_join ~backtrace:(Backtrace.Exn.am_recording ()) (fun () -> f x) in match result ~f ?config ?examples (module M) with | Ok () -> Ok () | Error (input, error) -> Or_error.error_s [%message "Base_quickcheck.Test.run: test failed" (input : M.t) (error : Error.t)] ;; let with_sample_exn ~f ?config ?examples generator = let f x = Or_error.try_with (fun () -> f x) in with_sample ~f ?config ?examples generator |> Or_error.ok_exn ;; let run_exn ~f ?config ?examples testable = let f x = Or_error.try_with ~backtrace:(Backtrace.Exn.am_recording ()) (fun () -> f x) in run ~f ?config ?examples testable |> Or_error.ok_exn ;; base_quickcheck-0.17.1/src/test.mli000066400000000000000000000002531501616613400171600ustar00rootroot00000000000000(** Use the Test module to run randomized tests. Each randomized test needs a generator, a shrinker, and a property to test. *) include Test_intf.Test (** @inline *) base_quickcheck-0.17.1/src/test_intf.ml000066400000000000000000000055141501616613400200340ustar00rootroot00000000000000open! Base module type S = sig type t [@@deriving sexp_of] val quickcheck_generator : t Generator.t val quickcheck_shrinker : t Shrinker.t end module type Test = sig module type S = S module Config : sig module Seed : sig type t = | Nondeterministic | Deterministic of string [@@deriving sexp_of] end type t = { seed : Seed.t (** [seed] is used to initialize the pseudo-random state before running tests of a property. *) ; test_count : int (** [test_count] determines how many random values to test a property with. *) ; shrink_count : int (** [shrink_count] determines the maximum number of attempts to find a smaller version of a value that fails a test. *) ; sizes : int Sequence.t (** [sizes] determines the progression of value sizes to generate while testing. Testing fails if [sizes] is not of length at least [test_count]. *) } [@@deriving sexp_of] end (** Defaults to a deterministic seed, [shrink_count] and [test_count] of 10_000 each, and sizes ranging from 0 to 30. *) val default_config : Config.t (** Tests the property [f], failing if it raises or returns [Error _]. Tests [f] first with any [examples], then with values from the given generator. Only random values count toward the [test_count] total, not values from [examples]. *) val run : f:('a -> unit Or_error.t) -> ?config:Config.t (** defaults to [default_config] *) -> ?examples:'a list (** defaults to the empty list *) -> (module S with type t = 'a) -> unit Or_error.t (** Like [run], but raises on failure. *) val run_exn : f:('a -> unit) -> ?config:Config.t (** defaults to [default_config] *) -> ?examples:'a list (** defaults to the empty list *) -> (module S with type t = 'a) -> unit (** Like [run], but does not catch exceptions raised by [f]. Allows arbitrary error types and returns the input that failed along with the error. *) val result : f:('a -> (unit, 'e) Result.t) -> ?config:Config.t (** defaults to [default_config] *) -> ?examples:'a list (** defaults to the empty list *) -> (module S with type t = 'a) -> (unit, 'a * 'e) Result.t (** Calls [f] with the sequence of values that [run] would get in the same configuration. *) val with_sample : f:('a Sequence.t -> unit Or_error.t) -> ?config:Config.t (** defaults to [default_config] *) -> ?examples:'a list (** defaults to the empty list *) -> 'a Generator.t -> unit Or_error.t (** Like [with_sample], but raises on failure. *) val with_sample_exn : f:('a Sequence.t -> unit) -> ?config:Config.t (** defaults to [default_config] *) -> ?examples:'a list (** defaults to the empty list *) -> 'a Generator.t -> unit end base_quickcheck-0.17.1/src/with_basic_types.ml000066400000000000000000000022231501616613400213670ustar00rootroot00000000000000open! Base module type S_bigarray = sig (** This helper module type exists separately just to [open Bigarray] in its scope. *) open Bigarray type 'a t val bigstring : (char, int8_unsigned_elt, c_layout) Array1.t t val float32_vec : (float, float32_elt, fortran_layout) Array1.t t val float64_vec : (float, float64_elt, fortran_layout) Array1.t t val float32_mat : (float, float32_elt, fortran_layout) Array2.t t val float64_mat : (float, float64_elt, fortran_layout) Array2.t t end module type S = sig type 'a t val unit : unit t val bool : bool t val char : char t val string : string t val bytes : bytes t val int : int t val int32 : int32 t val int63 : Int63.t t val int64 : int64 t val nativeint : nativeint t val float : float t val sexp : Sexp.t t val option : 'a t -> 'a option t val list : 'a t -> 'a list t val array : 'a t -> 'a array t val ref : 'a t -> 'a ref t val lazy_t : 'a t -> 'a Lazy.t t val both : 'a t -> 'b t -> ('a * 'b) t val either : 'a t -> 'b t -> ('a, 'b) Either.t t val result : 'a t -> 'b t -> ('a, 'b) Result.t t include S_bigarray with type 'a t := 'a t (** @inline *) end base_quickcheck-0.17.1/test/000077500000000000000000000000001501616613400156665ustar00rootroot00000000000000base_quickcheck-0.17.1/test/helpers/000077500000000000000000000000001501616613400173305ustar00rootroot00000000000000base_quickcheck-0.17.1/test/helpers/base_quickcheck_test_helpers.ml000066400000000000000000000410461501616613400255540ustar00rootroot00000000000000open! Base open Base_quickcheck open Expect_test_helpers_core include Base_quickcheck_test_helpers_intf let () = sexp_style := Sexp_style.simple_pretty let set_is_singleton set = Set.length set = 1 let arbitrary_int_gen = Generator.create (fun ~size:_ ~random -> Splittable_random.int random ~lo:Int.min_value ~hi:Int.max_value) ;; module Int_list = struct module T = struct type t = int list [@@deriving compare, sexp_of] end include T include Comparator.Make (T) end module type Partition_value = sig type t include Comparator.S with type t := t include With_examples with type t := t end (* Used in testing observers, to see which values map to distinct "buckets" by the observer's hash function. *) module Partitioning (Value : Partition_value) : sig type t [@@deriving compare, sexp_of] (* Create a partitioning of values based on a hash function. *) val create : (Value.t -> int) -> t (* Combine multiple partitionings to refine the buckets. For example, on different initial hash states or different sizes, two runs of an observer might differentiate different inputs. *) val union : t list -> t (* True if the partitioning maps each value to a separate bucket. *) val is_complete : t -> bool (* True if the partitioning maps every value to the same bucket. *) val is_singleton : t -> bool end = struct module Partition = struct module T = struct type t = (Value.t, Value.comparator_witness) Set.t let compare a b = Set.compare_m__t (module Value) a b let sexp_of_t t = Set.sexp_of_m__t (module Value) t end include T include Comparator.Make (T) let create list = Set.of_list (module Value) list end type t = { hash_keys : (Value.t, int list, Value.comparator_witness) Map.t ; partitions : (Partition.t, Partition.comparator_witness) Set.t } let compare a b = Set.compare_m__t (module Partition) a.partitions b.partitions let sexp_of_t t = Set.sexp_of_m__t (module Partition) t.partitions let of_hash_keys hash_keys = let partitions = Map.to_alist hash_keys |> List.map ~f:(fun (value, list) -> list, value) |> Map.of_alist_multi (module Int_list) |> Map.data |> List.map ~f:Partition.create |> Set.of_list (module Partition) in { hash_keys; partitions } ;; let create' hash_list_fn = Map.of_alist_exn (module Value) (List.map Value.examples ~f:(fun value -> value, hash_list_fn value)) |> of_hash_keys ;; let create hash_fn = create' (fun value -> [ hash_fn value ]) let union list = create' (fun value -> List.concat_map list ~f:(fun t -> Map.find_exn t.hash_keys value)) ;; let is_complete t = Set.for_all ~f:set_is_singleton t.partitions let is_singleton t = set_is_singleton t.partitions end let test_generator (type a) ?config ?(mode = `exhaustive) ?cr generator m = let (module Value : With_examples with type t = a) = m in let module Value = struct include Value include Comparator.Make (Value) end in Test.with_sample_exn generator ?config ~f:(fun sequence -> let generated_values = Sequence.to_list sequence in let distinct_generated_values = Set.of_list (module Value) generated_values in let distinct_known_values = Set.of_list (module Value) Value.examples in let failed_to_generate = Set.diff distinct_known_values distinct_generated_values in let message = if Set.equal distinct_generated_values distinct_known_values then [%message "exhaustive"] else ( let description = Printf.sprintf !"generated %{Int#hum} distinct values in %{Int#hum} iterations" (Set.length distinct_generated_values) (List.length generated_values) in let error_message = if Set.is_empty failed_to_generate then None else Some [%message "did not generate these values" ~_:(Set.to_list failed_to_generate : Value.t list)] in [%message description ~_:(error_message : (Sexp.t option[@sexp.option]))]) in print_s [%message "generator" ~_:(message : Sexp.t)]; match mode with | `exhaustive -> require [%here] ?cr (Set.is_empty failed_to_generate) ~if_false_then_print_s:(lazy [%message "failed to generate all known values"]) | `inexhaustive -> require [%here] ?cr (not (Set.is_empty failed_to_generate)) ~if_false_then_print_s: (lazy [%message "generated all known values even though we did not expect to"])) ;; let test_observer (type a) ?config ?(mode = `transparent) ?cr observer m = let (module Value : With_examples with type t = a) = m in let number_of_examples = List.length Value.examples in (* Not passing [?cr] here, this is not a soft test on observer properties, this is a performance bound based on the current implementation that all callsites should observe. *) require [%here] (number_of_examples <= 20) ~if_false_then_print_s: (lazy [%message "too many values; observer test will take too long" (number_of_examples : int) ~examples:(Value.examples : Value.t list)]); let module Value = struct include Value include Comparator.Make (Value) end in let module Partitioning = Partitioning (Value) in let hash_fn_gen = Generator.fn observer arbitrary_int_gen in Test.with_sample_exn hash_fn_gen ?config ~f:(fun sample -> let partitionings = Sequence.to_list (Sequence.map sample ~f:Partitioning.create) |> List.dedup_and_sort ~compare:Partitioning.compare in let partitions = Partitioning.union partitionings in let message = if Partitioning.is_complete partitions then [%message "transparent"] else if Partitioning.is_singleton partitions then [%message "opaque"] else [%message (partitions : Partitioning.t)] in print_s [%message "observer" ~_:(message : Sexp.t)]; match mode with | `transparent -> require [%here] ?cr (List.exists partitionings ~f:Partitioning.is_complete) ~if_false_then_print_s: (lazy [%message "did not generate any single function that distinguishes all values"]) | `opaque -> require [%here] ?cr (Partitioning.is_singleton partitions) ~if_false_then_print_s: (lazy [%message "generated functions did not treat input as opaque"])) ;; let test_shrinker (type a) ?config:_ ?(mode = `compound) ?cr shrinker m = let (module Value : With_examples with type t = a) = m in let alist = List.map Value.examples ~f:(fun value -> value, Sequence.to_list (Shrinker.shrink shrinker value)) |> List.filter ~f:(fun (_, list) -> not (List.is_empty list)) in let message = if List.is_empty alist then [%message "atomic"] else List.concat_map alist ~f:(fun (large, small_list) -> List.map small_list ~f:(fun small -> [%sexp (large : Value.t), "=>", (small : Value.t)])) |> [%sexp_of: Sexp.t list] in print_s [%message "shrinker" ~_:(message : Sexp.t)]; match mode with | `atomic -> require [%here] ?cr (List.is_empty alist) ~if_false_then_print_s:(lazy [%message "atomic shrinker should not shrink values"]) | `compound -> require [%here] ?cr (not (List.is_empty alist)) ~if_false_then_print_s:(lazy [%message "compound shrinker should shrink values"]) ;; let percent ~count ~total = Core.Percent.of_mult (Float.of_int count /. Float.of_int total) let show_distribution (type a) ?config ?(show = 20) generator m = let (module Value : Value with type t = a) = m in let module Value = struct include Value include Comparator.Make (Value) end in Test.with_sample_exn ?config generator ~f:(fun sample -> let sample = Sequence.to_list sample in let total = List.length sample in let value_by_count = sample |> List.map ~f:(fun value -> value, value) |> Map.of_alist_multi (module Value) |> Map.map ~f:(List.length :> _ -> _) |> Map.to_alist |> List.map ~f:(fun (value, count) -> count, value) |> List.sort ~compare:[%compare: int * Value.t] |> List.map ~f:(fun (count, value) -> percent ~count ~total, value) |> List.rev |> fun list -> List.take list show in print_s [%sexp (value_by_count : (Core.Percent.t * Value.t) list)]) ;; module type Exhaustive = sig type t [@@deriving enumerate] include Value with type t := t end let exhaustive (type a) (module Value : Exhaustive with type t = a) = (module struct include Value let examples = all end : With_examples with type t = a) ;; let m_unit = exhaustive (module Unit) let m_bool = exhaustive (module Bool) let m_char = (module struct include Char (* min and max of each: uppercase, lowercase, digit, punctuation, whitespace, other *) let examples = String.to_list "AZaz09!~ \t\000\255" end : With_examples with type t = char) ;; let m_biject (type a b) (module A : With_examples with type t = a) ~f ~f_inverse = (module struct type t = b let compare a b = Comparable.lift A.compare ~f:f_inverse a b let sexp_of_t t = A.sexp_of_t (f_inverse t) let examples = List.map A.examples ~f |> List.dedup_and_sort ~compare end : With_examples with type t = b) ;; let m_option (type value) (module Value : With_examples with type t = value) = (module struct type t = Value.t option [@@deriving compare, sexp_of] let examples = [ None ] @ List.map Value.examples ~f:Option.return end : With_examples with type t = value option) ;; let m_list (type elt) (module Elt : With_examples with type t = elt) = (module struct type t = Elt.t list [@@deriving sexp_of] let compare a b = Comparable.lift [%compare: int * Elt.t list] ~f:(fun t -> List.length t, t) a b ;; let examples = [ [] ] @ List.map Elt.examples ~f:(fun x -> [ x ]) @ List.map2_exn Elt.examples (List.rev Elt.examples) ~f:(fun x y -> [ x; y ]) ;; end : With_examples with type t = elt list) ;; let m_array m = m_biject (m_list m) ~f:Array.of_list ~f_inverse:Array.to_list let m_ref m = m_biject m ~f:Ref.create ~f_inverse:Ref.( ! ) let m_lazy_t m = m_biject m ~f:Lazy.from_val ~f_inverse:Lazy.force let m_arrow (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) = (module struct type t = A.t -> B.t let to_alist f = List.map A.examples ~f:(fun a -> a, f a) let compare a b = Comparable.lift [%compare: (A.t * B.t) list] ~f:to_alist a b let sexp_of_t t = [%sexp (to_alist t : (A.t * B.t) list)] let examples = if List.length A.examples <= 4 && List.length B.examples <= 4 then List.fold_right A.examples ~init:[ [] ] ~f:(fun a alists -> List.concat_map B.examples ~f:(fun b -> let pair = a, b in List.map alists ~f:(fun alist -> pair :: alist))) |> List.map ~f:(fun alist a -> List.Assoc.find alist a ~equal:[%compare.equal: A.t] |> Option.value ~default:(List.hd_exn B.examples)) else List.map B.examples ~f:Fn.const ;; end : With_examples with type t = a -> b) ;; let m_arrow_named (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) : (module With_examples with type t = x:a -> b) = m_biject (m_arrow (module A) (module B)) ~f:(fun f ~x -> f x) ~f_inverse:(fun f x -> f ~x) ;; let m_arrow_optional (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) : (module With_examples with type t = ?x:a -> unit -> b) = m_biject (m_arrow (m_option (module A)) (module B)) ~f:(fun f ?x () -> f x) ~f_inverse:(fun f x -> f ?x ()) ;; let m_either (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) = (module struct type t = (A.t, B.t) Either.t [@@deriving compare, sexp_of] let examples = List.map A.examples ~f:Either.first @ List.map B.examples ~f:Either.second ;; end : With_examples with type t = (a, b) Either.t) ;; let m_result (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) = (module struct type t = (A.t, B.t) Result.t [@@deriving compare, sexp_of] let examples = List.map A.examples ~f:(fun x -> Ok x) @ List.map B.examples ~f:(fun x -> Error x) ;; end : With_examples with type t = (a, b) Result.t) ;; let m_pair (type a b) (module A : With_examples with type t = a) (module B : With_examples with type t = b) = (module struct type t = A.t * B.t [@@deriving compare, sexp_of] let examples = List.cartesian_product A.examples B.examples end : With_examples with type t = a * b) ;; let m_triple (type a b c) (module A : With_examples with type t = a) (module B : With_examples with type t = b) (module C : With_examples with type t = c) = (module struct type t = A.t * B.t * C.t [@@deriving compare, sexp_of] let examples = List.cartesian_product (List.cartesian_product A.examples B.examples) C.examples |> List.map ~f:(fun ((a, b), c) -> a, b, c) ;; end : With_examples with type t = a * b * c) ;; let m_string = (module struct type t = string [@@deriving sexp_of] let compare a b = Comparable.lift [%compare: int * string] ~f:(fun string -> String.length string, string) a b ;; let examples = (* one of each: uppercase, lowercase, digit, punctuation, whitespace, other *) let chars = String.to_list "Az0_ \000" in [ "" ] @ List.map chars ~f:String.of_char @ List.map chars ~f:(fun char -> String.of_char char ^ String.of_char char) ;; end : With_examples with type t = string) ;; let m_bytes = m_biject m_string ~f:Bytes.of_string ~f_inverse:Bytes.to_string let m_nat ~up_to = (module struct type t = int [@@deriving compare, sexp_of] let examples = List.range 0 up_to ~start:`inclusive ~stop:`inclusive end : With_examples with type t = int) ;; let m_nat' (type i) ~up_to (module I : Int.S with type t = i) = (module struct type t = I.t [@@deriving compare, sexp_of] let examples = List.range 0 up_to ~start:`inclusive ~stop:`inclusive |> List.map ~f:I.of_int_exn ;; end : With_examples with type t = i) ;; let m_int (type a) (module I : Int.S with type t = a) = (module struct type t = I.t [@@deriving compare, sexp_of] let examples = [ I.min_value; I.minus_one; I.zero; I.one; I.max_value ] end : With_examples with type t = a) ;; let m_float = (module struct type t = float [@@deriving compare, sexp_of] let examples = [ Float.zero ; Float.min_positive_subnormal_value ; Float.min_positive_normal_value |> Float.one_ulp `Down ; Float.min_positive_normal_value ; Float.max_finite_value ; Float.infinity ; Float.nan ] |> List.concat_map ~f:(fun x -> [ Float.neg x; x ]) |> List.dedup_and_sort ~compare:Float.compare ;; end : With_examples with type t = float) ;; let m_sexp = (module struct type t = Sexp.t [@@deriving compare, sexp_of] let examples = let atoms = List.map ~f:(fun string -> Sexp.Atom string) [ "a"; "bc"; "def" ] in let lists_of_atoms = List.map atoms ~f:(fun atom -> Sexp.List [ atom ]) @ [ Sexp.List atoms ] in atoms @ lists_of_atoms @ [ Sexp.List (atoms @ lists_of_atoms) ] ;; end : With_examples with type t = Sexp.t) ;; let m_set (type elt cmp) (module Cmp : Comparator.S with type t = elt and type comparator_witness = cmp) (module Elt : With_examples with type t = elt) : (module With_examples with type t = (elt, cmp) Set.t) = m_biject (m_list (module Elt)) ~f:(Set.of_list (module Cmp)) ~f_inverse:Set.to_list ;; let m_map (type key data cmp) (module Cmp : Comparator.S with type t = key and type comparator_witness = cmp) (module Key : With_examples with type t = key) (module Data : With_examples with type t = data) = (module struct type t = (key, data, cmp) Map.t let compare = Map.compare_m__t (module Key) Data.compare let sexp_of_t = Map.sexp_of_m__t (module Key) Data.sexp_of_t let examples = [ Map.empty (module Cmp) ] @ List.map Data.examples ~f:(fun data -> Map.of_alist_exn (module Cmp) (List.map Key.examples ~f:(fun key -> key, data))) ;; end : With_examples with type t = (key, data, cmp) Map.t) ;; base_quickcheck-0.17.1/test/helpers/base_quickcheck_test_helpers.mli000066400000000000000000000001071501616613400257160ustar00rootroot00000000000000include Base_quickcheck_test_helpers_intf.Base_quickcheck_test_helpers base_quickcheck-0.17.1/test/helpers/base_quickcheck_test_helpers_intf.ml000066400000000000000000000117621501616613400265760ustar00rootroot00000000000000open! Base open Base_quickcheck module type Value = sig type t [@@deriving compare, sexp_of] end module type With_examples = sig type t [@@deriving compare, sexp_of] val examples : t list end module type Base_quickcheck_test_helpers = sig module type With_examples = With_examples (** This module provides rough sanity tests of generators, observers, and shrinkers based on a handful of example values for the relevant type. *) (** Tests whether the generator's distribution produces all the example values. Prints a cr if the result is inconsistent with the [~mode] argument. *) val test_generator : ?config:Test.Config.t -> ?mode:[ `exhaustive | `inexhaustive ] (** default: [`exhaustive] *) -> ?cr:Expect_test_helpers_core.CR.t -> 'a Generator.t -> (module With_examples with type t = 'a) -> unit (** Tests whether the observer can distinguish all examples from each other. Prints a cr if the result is inconsistent with the [~mode] argument. *) val test_observer : ?config:Test.Config.t -> ?mode:[ `transparent | `opaque ] (** default: [`transparent] *) -> ?cr:Expect_test_helpers_core.CR.t -> 'a Observer.t -> (module With_examples with type t = 'a) -> unit (** Tests whether the shrinker can produce smaller versions of any of the example values. Prints a cr if the result is inconsistent with the [~mode] argument. *) val test_shrinker : ?config:Test.Config.t -> ?mode:[ `compound | `atomic ] (** default: [`compound] *) -> ?cr:Expect_test_helpers_core.CR.t -> 'a Shrinker.t -> (module With_examples with type t = 'a) -> unit (** Shows the approximate distribution of output values for a generator based on [config.test_count] trials. *) val show_distribution : ?config:Test.Config.t -> ?show:int -> 'a Generator.t -> (module Value with type t = 'a) -> unit (** These first-class modules provide examples for use in the above tests. *) val m_int : (module Int.S with type t = 'a) -> (module With_examples with type t = 'a) val m_nat : up_to:int -> (module With_examples with type t = int) val m_nat' : up_to:int -> (module Int.S with type t = 'a) -> (module With_examples with type t = 'a) val m_unit : (module With_examples with type t = unit) val m_bool : (module With_examples with type t = bool) val m_char : (module With_examples with type t = char) val m_float : (module With_examples with type t = float) val m_string : (module With_examples with type t = string) val m_bytes : (module With_examples with type t = bytes) val m_sexp : (module With_examples with type t = Sexp.t) val m_option : (module With_examples with type t = 'a) -> (module With_examples with type t = 'a option) val m_list : (module With_examples with type t = 'a) -> (module With_examples with type t = 'a list) val m_array : (module With_examples with type t = 'a) -> (module With_examples with type t = 'a array) val m_ref : (module With_examples with type t = 'a) -> (module With_examples with type t = 'a ref) val m_lazy_t : (module With_examples with type t = 'a) -> (module With_examples with type t = 'a lazy_t) val m_either : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = ('a, 'b) Either.t) val m_result : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = ('a, 'b) Result.t) val m_pair : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = 'a * 'b) val m_triple : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = 'c) -> (module With_examples with type t = 'a * 'b * 'c) val m_arrow : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = 'a -> 'b) val m_arrow_named : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = x:'a -> 'b) val m_arrow_optional : (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = ?x:'a -> unit -> 'b) val m_set : (module Comparator.S with type t = 'a and type comparator_witness = 'c) -> (module With_examples with type t = 'a) -> (module With_examples with type t = ('a, 'c) Set.t) val m_map : (module Comparator.S with type t = 'a and type comparator_witness = 'c) -> (module With_examples with type t = 'a) -> (module With_examples with type t = 'b) -> (module With_examples with type t = ('a, 'b, 'c) Map.t) val m_biject : (module With_examples with type t = 'a) -> f:('a -> 'b) -> f_inverse:('b -> 'a) -> (module With_examples with type t = 'b) end base_quickcheck-0.17.1/test/helpers/dune000066400000000000000000000002111501616613400202000ustar00rootroot00000000000000(library (name base_quickcheck_test_helpers) (libraries base base_quickcheck expect_test_helpers_core) (preprocess (pps ppx_jane))) base_quickcheck-0.17.1/test/src/000077500000000000000000000000001501616613400164555ustar00rootroot00000000000000base_quickcheck-0.17.1/test/src/dune000066400000000000000000000002411501616613400173300ustar00rootroot00000000000000(library (name test_base_quickcheck) (libraries base base_quickcheck base_quickcheck_test_helpers expect_test_helpers_core) (preprocess (pps ppx_jane))) base_quickcheck-0.17.1/test/src/import.ml000066400000000000000000000002101501616613400203120ustar00rootroot00000000000000include Base include Expect_test_helpers_core include Base_quickcheck include Base_quickcheck_test_helpers include Generator.Let_syntax base_quickcheck-0.17.1/test/src/test_base_quickcheck.ml000066400000000000000000000006151501616613400231540ustar00rootroot00000000000000module Generator = Test_generator module Observer = Test_observer module Shrinker = Test_shrinker module Test = Test_test (* This module contains only a module type. *) module With_basic_types = Base_quickcheck.With_basic_types (* This module contains only aliases to values already tested above. *) module Export = Base_quickcheck.Export include Export module Private = Base_quickcheck.Private base_quickcheck-0.17.1/test/src/test_base_quickcheck.mli000066400000000000000000000000771501616613400233270ustar00rootroot00000000000000include module type of Base_quickcheck [@ocaml.remove_aliases] base_quickcheck-0.17.1/test/src/test_generator.ml000066400000000000000000001627301501616613400220450ustar00rootroot00000000000000open! Base open! Import type 'a t = 'a Generator.t let create = Generator.create let generate = Generator.generate let%expect_test "create & generate" = let int_up_to_size = Generator.create (fun ~size ~random -> Splittable_random.int random ~lo:0 ~hi:size) in let random = Splittable_random.create Random.State.default in List.init 30 ~f:(fun size -> Generator.generate int_up_to_size ~size ~random) |> [%sexp_of: int list] |> print_s; [%expect {| (0 1 1 1 1 1 3 0 8 7 1 8 11 13 12 7 6 6 0 8 16 4 15 2 6 14 4 24 16 11) |}]; require_does_raise [%here] (fun () -> Generator.generate int_up_to_size ~size:(-1) ~random:(Splittable_random.of_int 0)); [%expect {| ("Base_quickcheck.Generator.generate: size < 0" (size -1)) |}] ;; include (Generator : Applicative.S with type 'a t := 'a t) include (Generator : Monad.S with type 'a t := 'a t) open struct (* We want to use a consistent test count on 32- and 64-bit targets since these tests reflect on the actual trials and distributions. *) let config = { Test.default_config with test_count = 10_000 } let test_generator ?mode ?cr t m = test_generator ~config ?mode ?cr t m let show_distribution ?show t m = show_distribution ~config ?show t m end let%expect_test "return" = test_generator (Generator.return ()) m_unit; [%expect {| (generator exhaustive) |}]; test_generator ~mode:`inexhaustive (Generator.return false) m_bool; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (true)))) |}] ;; let%expect_test "map" = test_generator (Generator.map Generator.char ~f:Char.is_print) m_bool; [%expect {| (generator exhaustive) |}] ;; let%expect_test "both" = test_generator (Generator.both Generator.bool Generator.bool) (m_pair m_bool m_bool); [%expect {| (generator exhaustive) |}] ;; let%expect_test "bind" = test_generator ~mode:`inexhaustive (Generator.bind Generator.bool ~f:(fun bool -> let gen = Generator.return bool in Generator.both gen gen)) (m_pair m_bool m_bool); [%expect {| (generator ("generated 2 distinct values in 10_000 iterations" ("did not generate these values" ((false true) (true false))))) |}] ;; let perturb = Generator.perturb let%expect_test "perturb" = let gen = Generator.create (fun ~size:_ ~random -> Splittable_random.int random ~lo:0 ~hi:9) in let size = 0 in List.init 10 ~f:(fun salt -> let random = Splittable_random.of_int 0 in let gen = Generator.perturb gen salt in List.init 10 ~f:(fun _ -> Generator.generate gen ~size ~random)) |> [%sexp_of: int list list] |> print_s; [%expect {| ((0 4 0 6 0 1 4 9 1 6) (2 4 9 9 1 2 5 0 8 5) (7 3 6 0 5 0 0 2 5 5) (8 5 6 5 4 2 1 9 1 2) (8 0 7 4 9 0 5 8 4 5) (0 1 5 1 5 9 4 7 4 7) (3 8 6 8 5 6 9 9 6 5) (0 4 1 3 5 6 6 6 3 5) (5 0 9 7 6 5 9 1 6 0) (0 6 8 8 1 7 7 9 4 0)) |}] ;; let size = Generator.size let%expect_test "size" = test_generator Generator.size (m_nat ~up_to:30); [%expect {| (generator exhaustive) |}] ;; let sizes = Generator.sizes let%expect_test "sizes" = test_generator ~mode:`inexhaustive (Generator.sizes ()) (m_list (m_nat ~up_to:10)); [%expect {| (generator ("generated 3_724 distinct values in 10_000 iterations" ("did not generate these values" ((0 10) (10 0))))) |}]; (* The most common size lists: *) show_distribution (Generator.sizes ()) (module struct type t = int list [@@deriving compare, sexp_of] end); [%expect {| ((24.63% ()) (1.65% (0)) (1.12% (2)) (1.06% (1)) (91bp (0 0)) (87bp (6)) (83bp (0 0 0 0)) (77bp (8)) (73bp (5)) (73bp (4)) (72bp (7)) (68bp (3)) (64bp (15)) (62bp (25)) (61bp (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (60bp (14)) (60bp (10)) (60bp (0 0 0 0 0 0 0 0)) (59bp (11)) (58bp (13))) |}]; (* The most common lengths of a size list: *) show_distribution (Generator.sizes () |> Generator.map ~f:(List.length :> _ -> _)) (module Int); [%expect {| ((24.63% 0) (19.39% 1) (9.58% 2) (8.72% 3) (4.96% 4) (4.13% 5) (3.77% 6) (3.52% 7) (2.63% 8) (2.15% 9) (1.75% 16) (1.67% 10) (1.61% 12) (1.37% 13) (1.32% 11) (1.27% 17) (1.25% 15) (1.18% 14) (1.06% 18) (76bp 21)) |}]; (* The most common number of non-zero sizes in a size list: *) show_distribution (Generator.sizes () |> Generator.map ~f:(List.count ~f:(Int.( <> ) 0))) (module Int); [%expect {| ((32.65% 0) (23.74% 1) (12.01% 2) (10.74% 3) (6.18% 4) (5.22% 5) (4.64% 6) (2.69% 7) (1.38% 8) (56bp 9) (13bp 10) (6bp 11)) |}] ;; let with_size = Generator.with_size let%expect_test "with_size" = test_generator ~mode:`inexhaustive (Generator.with_size ~size:0 Generator.size) (m_nat ~up_to:10); [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (1 2 3 4 5 6 7 8 9 10)))) |}] ;; let filter = Generator.filter let%expect_test "filter" = let is_even int = int % 2 = 0 in test_generator ~mode:`inexhaustive (Generator.filter ~f:is_even Generator.size) (m_nat ~up_to:30); [%expect {| (generator ("generated 16 distinct values in 10_000 iterations" ("did not generate these values" (1 3 5 7 9 11 13 15 17 19 21 23 25 27 29)))) |}] ;; let filter_map = Generator.filter_map let%expect_test "filter_map" = let exactly_half int = if int % 2 = 0 then Some (int / 2) else None in test_generator (Generator.filter_map ~f:exactly_half Generator.size) (m_nat ~up_to:15); [%expect {| (generator exhaustive) |}] ;; let of_list = Generator.of_list let%expect_test "of_list" = test_generator (Generator.of_list Bool.all) m_bool; [%expect {| (generator exhaustive) |}] ;; let of_weighted_list = Generator.of_weighted_list let%expect_test "of_weighted_list" = test_generator ~mode:`inexhaustive (Generator.of_weighted_list (List.init 31 ~f:(fun size -> Float.of_int size, size))) (m_nat ~up_to:30); [%expect {| (generator ("generated 30 distinct values in 10_000 iterations" ("did not generate these values" (0)))) |}] ;; let union = Generator.union let%expect_test "union" = test_generator (Generator.union (List.init 31 ~f:(fun size -> Generator.return size))) (m_nat ~up_to:30); [%expect {| (generator exhaustive) |}] ;; let weighted_union = Generator.weighted_union let%expect_test "weighted_union" = test_generator ~mode:`inexhaustive (Generator.weighted_union (List.init 31 ~f:(fun size -> Float.of_int size, Generator.return size))) (m_nat ~up_to:30); [%expect {| (generator ("generated 30 distinct values in 10_000 iterations" ("did not generate these values" (0)))) |}] ;; let fixed_point = Generator.fixed_point let%expect_test "fixed_point" = test_generator ~mode:`inexhaustive (Generator.fixed_point (fun generator -> Generator.bind Generator.bool ~f:(function | false -> Generator.return 0 | true -> Generator.map generator ~f:Int.succ))) (m_nat ~up_to:30); [%expect {| (generator ("generated 15 distinct values in 10_000 iterations" ("did not generate these values" (14 15 16 17 19 20 21 22 23 24 25 26 27 28 29 30)))) |}]; (* [fixed_point] should only have to call its argument once *) let recursive_calls = ref 0 in let values_generated = ref 0 in Test.with_sample_exn ~config ~f:(Sequence.iter ~f:(fun () -> Int.incr values_generated)) (Generator.fixed_point (fun _ -> Int.incr recursive_calls; Generator.unit)); print_s [%message "" (recursive_calls : int ref) (values_generated : int ref)]; require_equal [%here] (module Int) !recursive_calls 1; require_equal [%here] (module Int) !values_generated 10_000; [%expect {| ((recursive_calls 1) (values_generated 10000)) |}] ;; let recursive_union = Generator.recursive_union let%expect_test "recursive_union" = test_generator ~mode:`inexhaustive (Generator.recursive_union [ Generator.of_list [ "a"; "bc"; "def" ] |> Generator.map ~f:(fun atom -> Sexp.Atom atom) ] ~f:(fun sexp -> [ Generator.list sexp |> Generator.map ~f:(fun list -> Sexp.List list) ])) m_sexp; [%expect {| (generator ("generated 2_519 distinct values in 10_000 iterations" ("did not generate these values" ((a bc def (a) (bc) (def) (a bc def)))))) |}]; (* [recursive_union] should only have to call its argument once *) let recursive_calls = ref 0 in let values_generated = ref 0 in Test.with_sample_exn ~config ~f:(Sequence.iter ~f:(fun () -> Int.incr values_generated)) (Generator.recursive_union [ Generator.unit ] ~f:(fun _ -> Int.incr recursive_calls; [ Generator.unit ])); print_s [%message "" (recursive_calls : int ref) (values_generated : int ref)]; require_equal [%here] (module Int) !recursive_calls 1; require_equal [%here] (module Int) !values_generated 10_000; [%expect {| ((recursive_calls 1) (values_generated 10000)) |}] ;; let weighted_recursive_union = Generator.weighted_recursive_union let%expect_test "weighted_recursive_union" = test_generator ~mode:`inexhaustive (Generator.weighted_recursive_union [ ( 2. , Generator.of_list [ "a"; "bc"; "def" ] |> Generator.map ~f:(fun atom -> Sexp.Atom atom) ) ] ~f:(fun sexp -> [ 1., Generator.list sexp |> Generator.map ~f:(fun list -> Sexp.List list) ])) m_sexp; [%expect {| (generator ("generated 1_520 distinct values in 10_000 iterations" ("did not generate these values" ((a bc def (a) (bc) (def) (a bc def)))))) |}]; (* [weighted_recursive_union] should only have to call its argument once *) let recursive_calls = ref 0 in let values_generated = ref 0 in Test.with_sample_exn ~config ~f:(Sequence.iter ~f:(fun () -> Int.incr values_generated)) (Generator.weighted_recursive_union [ 1., Generator.unit ] ~f:(fun _ -> Int.incr recursive_calls; [ 2., Generator.unit ])); print_s [%message "" (recursive_calls : int ref) (values_generated : int ref)]; require_equal [%here] (module Int) !recursive_calls 1; require_equal [%here] (module Int) !values_generated 10_000; [%expect {| ((recursive_calls 1) (values_generated 10000)) |}] ;; let fn = Generator.fn let%expect_test "fn" = test_generator (Generator.fn Observer.bool Generator.bool) (m_arrow m_bool m_bool); [%expect {| (generator exhaustive) |}] ;; let unit = Generator.unit let%expect_test "unit" = test_generator Generator.unit m_unit; [%expect {| (generator exhaustive) |}] ;; let bool = Generator.bool let%expect_test "bool" = test_generator Generator.bool m_bool; [%expect {| (generator exhaustive) |}] ;; let option = Generator.option let%expect_test "option" = test_generator (Generator.option Generator.bool) (m_option m_bool); [%expect {| (generator exhaustive) |}] ;; let either = Generator.either let%expect_test "either" = test_generator (Generator.either Generator.bool Generator.bool) (m_either m_bool m_bool); [%expect {| (generator exhaustive) |}] ;; let result = Generator.result let%expect_test "result" = test_generator (Generator.result Generator.bool Generator.bool) (m_result m_bool m_bool); [%expect {| (generator exhaustive) |}] ;; let map_t_m = Generator.map_t_m let map_tree_using_comparator = Generator.map_tree_using_comparator let%expect_test "map_t_m" = test_generator (Generator.map_t_m (module Bool) Generator.bool Generator.bool) (m_map (module Bool) m_bool m_bool); [%expect {| (generator "generated 9 distinct values in 10_000 iterations") |}] ;; let set_t_m = Generator.set_t_m let set_tree_using_comparator = Generator.set_tree_using_comparator let%expect_test "set_t_m" = test_generator (Generator.set_t_m (module Bool) Generator.bool) (m_set (module Bool) m_bool); [%expect {| (generator exhaustive) |}] ;; let small_positive_or_zero_int = Generator.small_positive_or_zero_int let%expect_test "small_positive_or_zero_int" = test_generator Generator.small_positive_or_zero_int (m_nat ~up_to:31); [%expect {| (generator exhaustive) |}] ;; let small_strictly_positive_int = Generator.small_strictly_positive_int let%expect_test "small_strictly_positive_int" = test_generator ~mode:`inexhaustive Generator.small_strictly_positive_int (m_nat ~up_to:31); [%expect {| (generator ("generated 31 distinct values in 10_000 iterations" ("did not generate these values" (0)))) |}] ;; let int = Generator.int let%expect_test ("int" [@tags "64-bits-only"]) = test_generator Generator.int (m_int (module Int)); [%expect {| (generator "generated 8_006 distinct values in 10_000 iterations") |}] ;; let int_uniform = Generator.int_uniform let%expect_test ("int_uniform" [@tags "64-bits-only"]) = test_generator ~mode:`inexhaustive Generator.int_uniform (m_int (module Int)); [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (-4611686018427387904 -1 0 1 4611686018427387903)))) |}] ;; let int_inclusive = Generator.int_inclusive let%expect_test "int_inclusive" = test_generator (Generator.int_inclusive 0 10) (m_nat ~up_to:10); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int_inclusive 0 10) (module Int); [%expect {| ((12.96% 0) (12.63% 10) (8.62% 9) (8.53% 5) (8.46% 1) (8.44% 8) (8.25% 4) (8.21% 2) (8.18% 6) (8.15% 7) (7.57% 3)) |}] ;; let int_uniform_inclusive = Generator.int_uniform_inclusive let%expect_test "int_uniform_inclusive" = test_generator (Generator.int_uniform_inclusive 0 10) (m_nat ~up_to:10); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int_uniform_inclusive 0 10) (module Int); [%expect {| ((9.55% 5) (9.54% 0) (9.21% 9) (9.18% 1) (9.14% 4) (9.01% 7) (8.95% 10) (8.89% 8) (8.88% 3) (8.86% 2) (8.79% 6)) |}] ;; let int_log_inclusive = Generator.int_log_inclusive let%expect_test "int_log_inclusive" = test_generator (Generator.int_log_inclusive 0 10) (m_nat ~up_to:10); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int_log_inclusive 0 10) (module Int); [%expect {| ((22.24% 0) (18.67% 1) (10.43% 10) (9.47% 3) (9.12% 2) (6.03% 8) (6% 9) (4.82% 5) (4.59% 4) (4.37% 7) (4.26% 6)) |}] ;; let int_log_uniform_inclusive = Generator.int_log_uniform_inclusive let%expect_test "int_log_uniform_inclusive" = test_generator (Generator.int_log_uniform_inclusive 0 10) (m_nat ~up_to:10); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int_log_uniform_inclusive 0 10) (module Int); [%expect {| ((19.96% 0) (19.8% 1) (10.19% 3) (9.98% 2) (6.74% 9) (6.64% 8) (6.59% 10) (5.11% 6) (5.08% 5) (5.07% 7) (4.84% 4)) |}] ;; let int_geometric = Generator.int_geometric let%expect_test "int_geometric" = let test n p = let gen = Generator.int_geometric n ~p in test_generator gen (m_nat ~up_to:n) ~mode:(if n <= 0 then `exhaustive else `inexhaustive); show_distribution gen (module Int) ~show:4 in (* check that we stay above the lower bound, test sensible distributions *) test 1 0.25; [%expect {| (generator ("generated 29 distinct values in 10_000 iterations" ("did not generate these values" (0)))) ((25.65% 1) (18.97% 2) (14.45% 3) (10.34% 4)) |}]; test 2 0.5; [%expect {| (generator ("generated 14 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((50.77% 2) (25.07% 3) (11.79% 4) (5.78% 5)) |}]; test (-3) 0.75; [%expect {| (generator "generated 8 distinct values in 10_000 iterations") ((75.84% -3) (17.57% -2) (4.97% -1) (1.2% 0)) |}]; (* test a very low [p] *) test 1 Float.min_positive_subnormal_value; expect_test_output [%here] |> replace ~pattern:(Int.to_string Int.max_value) ~with_:"MAX_VALUE" |> print_string; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((1x MAX_VALUE)) |}]; (* test bounds checking *) require_does_raise [%here] (fun () -> Generator.int_geometric 0 ~p:Float.nan); [%expect {| ("geometric distribution: p must be between 0 and 1" (p NAN)) |}]; require_does_raise [%here] (fun () -> Generator.int_geometric 0 ~p:(-1.)); [%expect {| ("geometric distribution: p must be between 0 and 1" (p -1)) |}]; require_does_raise [%here] (fun () -> Generator.int_geometric 0 ~p:2.); [%expect {| ("geometric distribution: p must be between 0 and 1" (p 2)) |}] ;; let int32 = Generator.int32 let%expect_test "int32" = test_generator Generator.int32 (m_int (module Int32)); [%expect {| (generator "generated 6_769 distinct values in 10_000 iterations") |}] ;; let int32_uniform = Generator.int32_uniform let%expect_test "int32_uniform" = test_generator ~mode:`inexhaustive Generator.int32_uniform (m_int (module Int32)); [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (-2147483648 -1 0 1 2147483647)))) |}] ;; let int32_inclusive = Generator.int32_inclusive let%expect_test "int32_inclusive" = test_generator (Generator.int32_inclusive 0l 10l) (m_nat' ~up_to:10 (module Int32)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int32_inclusive 0l 10l) (module Int32); [%expect {| ((12.96% 0) (12.63% 10) (8.62% 9) (8.53% 5) (8.46% 1) (8.44% 8) (8.25% 4) (8.21% 2) (8.18% 6) (8.15% 7) (7.57% 3)) |}] ;; let int32_uniform_inclusive = Generator.int32_uniform_inclusive let%expect_test "int32_uniform_inclusive" = test_generator (Generator.int32_uniform_inclusive 0l 10l) (m_nat' ~up_to:10 (module Int32)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int32_uniform_inclusive 0l 10l) (module Int32); [%expect {| ((9.55% 5) (9.54% 0) (9.21% 9) (9.18% 1) (9.14% 4) (9.01% 7) (8.95% 10) (8.89% 8) (8.88% 3) (8.86% 2) (8.79% 6)) |}] ;; let int32_log_inclusive = Generator.int32_log_inclusive let%expect_test "int32_log_inclusive" = test_generator (Generator.int32_log_inclusive 0l 10l) (m_nat' ~up_to:10 (module Int32)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int32_log_inclusive 0l 10l) (module Int32); [%expect {| ((22.24% 0) (18.67% 1) (10.43% 10) (9.47% 3) (9.12% 2) (6.03% 8) (6% 9) (4.82% 5) (4.59% 4) (4.37% 7) (4.26% 6)) |}] ;; let int32_log_uniform_inclusive = Generator.int32_log_uniform_inclusive let%expect_test "int32_log_uniform_inclusive" = test_generator (Generator.int32_log_uniform_inclusive 0l 10l) (m_nat' ~up_to:10 (module Int32)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int32_log_uniform_inclusive 0l 10l) (module Int32); [%expect {| ((19.96% 0) (19.8% 1) (10.19% 3) (9.98% 2) (6.74% 9) (6.64% 8) (6.59% 10) (5.11% 6) (5.08% 5) (5.07% 7) (4.84% 4)) |}] ;; let int32_geometric = Generator.int32_geometric let%expect_test "int32_geometric" = let test n p = let gen = Generator.int32_geometric (Int32.of_int_exn n) ~p in test_generator gen (m_nat' ~up_to:n (module Int32)) ~mode:(if n <= 0 then `exhaustive else `inexhaustive); show_distribution gen (module Int32) ~show:4 in (* check that we stay above the lower bound, test sensible distributions *) test 1 0.25; [%expect {| (generator ("generated 29 distinct values in 10_000 iterations" ("did not generate these values" (0)))) ((25.65% 1) (18.97% 2) (14.45% 3) (10.34% 4)) |}]; test 2 0.5; [%expect {| (generator ("generated 14 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((50.77% 2) (25.07% 3) (11.79% 4) (5.78% 5)) |}]; test (-3) 0.75; [%expect {| (generator "generated 8 distinct values in 10_000 iterations") ((75.84% -3) (17.57% -2) (4.97% -1) (1.2% 0)) |}]; (* test a very low [p] *) test 1 Float.min_positive_subnormal_value; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((1x 2147483647)) |}]; (* test bounds checking *) require_does_raise [%here] (fun () -> Generator.int32_geometric 0l ~p:Float.nan); [%expect {| ("geometric distribution: p must be between 0 and 1" (p NAN)) |}]; require_does_raise [%here] (fun () -> Generator.int32_geometric 0l ~p:(-1.)); [%expect {| ("geometric distribution: p must be between 0 and 1" (p -1)) |}]; require_does_raise [%here] (fun () -> Generator.int32_geometric 0l ~p:2.); [%expect {| ("geometric distribution: p must be between 0 and 1" (p 2)) |}] ;; let int63 = Generator.int63 let%expect_test "int63" = test_generator Generator.int63 (m_int (module Int63)); [%expect {| (generator "generated 8_006 distinct values in 10_000 iterations") |}] ;; let int63_uniform = Generator.int63_uniform let%expect_test "int63_uniform" = test_generator ~mode:`inexhaustive Generator.int63_uniform (m_int (module Int63)); [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (-4611686018427387904 -1 0 1 4611686018427387903)))) |}] ;; let int63_inclusive = Generator.int63_inclusive let%expect_test "int63_inclusive" = test_generator (Generator.int63_inclusive Int63.zero (Int63.of_int_exn 10)) (m_nat' ~up_to:10 (module Int63)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int63_inclusive Int63.zero (Int63.of_int_exn 10)) (module Int63); [%expect {| ((12.96% 0) (12.63% 10) (8.62% 9) (8.53% 5) (8.46% 1) (8.44% 8) (8.25% 4) (8.21% 2) (8.18% 6) (8.15% 7) (7.57% 3)) |}] ;; let int63_uniform_inclusive = Generator.int63_uniform_inclusive let%expect_test "int63_uniform_inclusive" = test_generator (Generator.int63_uniform_inclusive Int63.zero (Int63.of_int_exn 10)) (m_nat' ~up_to:10 (module Int63)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int63_uniform_inclusive Int63.zero (Int63.of_int_exn 10)) (module Int63); [%expect {| ((9.55% 5) (9.54% 0) (9.21% 9) (9.18% 1) (9.14% 4) (9.01% 7) (8.95% 10) (8.89% 8) (8.88% 3) (8.86% 2) (8.79% 6)) |}] ;; let int63_log_inclusive = Generator.int63_log_inclusive let%expect_test "int63_log_inclusive" = test_generator (Generator.int63_log_inclusive Int63.zero (Int63.of_int_exn 10)) (m_nat' ~up_to:10 (module Int63)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int63_log_inclusive Int63.zero (Int63.of_int_exn 10)) (module Int63); [%expect {| ((22.24% 0) (18.67% 1) (10.43% 10) (9.47% 3) (9.12% 2) (6.03% 8) (6% 9) (4.82% 5) (4.59% 4) (4.37% 7) (4.26% 6)) |}] ;; let int63_log_uniform_inclusive = Generator.int63_log_uniform_inclusive let%expect_test "int63_log_uniform_inclusive" = test_generator (Generator.int63_log_uniform_inclusive Int63.zero (Int63.of_int_exn 10)) (m_nat' ~up_to:10 (module Int63)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int63_log_uniform_inclusive Int63.zero (Int63.of_int_exn 10)) (module Int63); [%expect {| ((19.96% 0) (19.8% 1) (10.19% 3) (9.98% 2) (6.74% 9) (6.64% 8) (6.59% 10) (5.11% 6) (5.08% 5) (5.07% 7) (4.84% 4)) |}] ;; let int63_geometric = Generator.int63_geometric let%expect_test "int63_geometric" = let test n p = let gen = Generator.int63_geometric (Int63.of_int_exn n) ~p in test_generator gen (m_nat' ~up_to:n (module Int63)) ~mode:(if n <= 0 then `exhaustive else `inexhaustive); show_distribution gen (module Int63) ~show:4 in (* check that we stay above the lower bound, test sensible distributions *) test 1 0.25; [%expect {| (generator ("generated 29 distinct values in 10_000 iterations" ("did not generate these values" (0)))) ((25.65% 1) (18.97% 2) (14.45% 3) (10.34% 4)) |}]; test 2 0.5; [%expect {| (generator ("generated 14 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((50.77% 2) (25.07% 3) (11.79% 4) (5.78% 5)) |}]; test (-3) 0.75; [%expect {| (generator "generated 8 distinct values in 10_000 iterations") ((75.84% -3) (17.57% -2) (4.97% -1) (1.2% 0)) |}]; (* test a very low [p] *) test 1 Float.min_positive_subnormal_value; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((1x 4611686018427387903)) |}]; (* test bounds checking *) require_does_raise [%here] (fun () -> Generator.int63_geometric Int63.zero ~p:Float.nan); [%expect {| ("geometric distribution: p must be between 0 and 1" (p NAN)) |}]; require_does_raise [%here] (fun () -> Generator.int63_geometric Int63.zero ~p:(-1.)); [%expect {| ("geometric distribution: p must be between 0 and 1" (p -1)) |}]; require_does_raise [%here] (fun () -> Generator.int63_geometric Int63.zero ~p:2.); [%expect {| ("geometric distribution: p must be between 0 and 1" (p 2)) |}] ;; let int64 = Generator.int64 let%expect_test "int64" = test_generator Generator.int64 (m_int (module Int64)); [%expect {| (generator "generated 8_047 distinct values in 10_000 iterations") |}] ;; let int64_uniform = Generator.int64_uniform let%expect_test "int64_uniform" = test_generator ~mode:`inexhaustive Generator.int64_uniform (m_int (module Int64)); [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (-9223372036854775808 -1 0 1 9223372036854775807)))) |}] ;; let int64_inclusive = Generator.int64_inclusive let%expect_test "int64_inclusive" = test_generator (Generator.int64_inclusive 0L 10L) (m_nat' ~up_to:10 (module Int64)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int64_inclusive 0L 10L) (module Int64); [%expect {| ((12.96% 0) (12.63% 10) (8.62% 9) (8.53% 5) (8.46% 1) (8.44% 8) (8.25% 4) (8.21% 2) (8.18% 6) (8.15% 7) (7.57% 3)) |}] ;; let int64_uniform_inclusive = Generator.int64_uniform_inclusive let%expect_test "int64_uniform_inclusive" = test_generator (Generator.int64_uniform_inclusive 0L 10L) (m_nat' ~up_to:10 (module Int64)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int64_uniform_inclusive 0L 10L) (module Int64); [%expect {| ((9.55% 5) (9.54% 0) (9.21% 9) (9.18% 1) (9.14% 4) (9.01% 7) (8.95% 10) (8.89% 8) (8.88% 3) (8.86% 2) (8.79% 6)) |}] ;; let int64_log_inclusive = Generator.int64_log_inclusive let%expect_test "int64_log_inclusive" = test_generator (Generator.int64_log_inclusive 0L 10L) (m_nat' ~up_to:10 (module Int64)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int64_log_inclusive 0L 10L) (module Int64); [%expect {| ((22.24% 0) (18.67% 1) (10.43% 10) (9.47% 3) (9.12% 2) (6.03% 8) (6% 9) (4.82% 5) (4.59% 4) (4.37% 7) (4.26% 6)) |}] ;; let int64_log_uniform_inclusive = Generator.int64_log_uniform_inclusive let%expect_test "int64_log_uniform_inclusive" = test_generator (Generator.int64_log_uniform_inclusive 0L 10L) (m_nat' ~up_to:10 (module Int64)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.int64_log_uniform_inclusive 0L 10L) (module Int64); [%expect {| ((19.96% 0) (19.8% 1) (10.19% 3) (9.98% 2) (6.74% 9) (6.64% 8) (6.59% 10) (5.11% 6) (5.08% 5) (5.07% 7) (4.84% 4)) |}] ;; let int64_geometric = Generator.int64_geometric let%expect_test "int64_geometric" = let test n p = let gen = Generator.int64_geometric (Int64.of_int_exn n) ~p in test_generator gen (m_nat' ~up_to:n (module Int64)) ~mode:(if n <= 0 then `exhaustive else `inexhaustive); show_distribution gen (module Int64) ~show:4 in (* check that we stay above the lower bound, test sensible distributions *) test 1 0.25; [%expect {| (generator ("generated 29 distinct values in 10_000 iterations" ("did not generate these values" (0)))) ((25.65% 1) (18.97% 2) (14.45% 3) (10.34% 4)) |}]; test 2 0.5; [%expect {| (generator ("generated 14 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((50.77% 2) (25.07% 3) (11.79% 4) (5.78% 5)) |}]; test (-3) 0.75; [%expect {| (generator "generated 8 distinct values in 10_000 iterations") ((75.84% -3) (17.57% -2) (4.97% -1) (1.2% 0)) |}]; (* test a very low [p] *) test 1 Float.min_positive_subnormal_value; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((1x 9223372036854775807)) |}]; (* test bounds checking *) require_does_raise [%here] (fun () -> Generator.int64_geometric 0L ~p:Float.nan); [%expect {| ("geometric distribution: p must be between 0 and 1" (p NAN)) |}]; require_does_raise [%here] (fun () -> Generator.int64_geometric 0L ~p:(-1.)); [%expect {| ("geometric distribution: p must be between 0 and 1" (p -1)) |}]; require_does_raise [%here] (fun () -> Generator.int64_geometric 0L ~p:2.); [%expect {| ("geometric distribution: p must be between 0 and 1" (p 2)) |}] ;; let nativeint = Generator.nativeint let%expect_test ("nativeint" [@tags "64-bits-only"]) = test_generator Generator.nativeint (m_int (module Nativeint)); [%expect {| (generator "generated 8_047 distinct values in 10_000 iterations") |}] ;; let nativeint_uniform = Generator.nativeint_uniform let%expect_test ("nativeint_uniform" [@tags "64-bits-only"]) = test_generator ~mode:`inexhaustive Generator.nativeint_uniform (m_int (module Nativeint)); [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (-9223372036854775808 -1 0 1 9223372036854775807)))) |}] ;; let nativeint_inclusive = Generator.nativeint_inclusive let%expect_test "nativeint_inclusive" = test_generator (Generator.nativeint_inclusive 0n 10n) (m_nat' ~up_to:10 (module Nativeint)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.nativeint_inclusive 0n 10n) (module Nativeint); [%expect {| ((12.96% 0) (12.63% 10) (8.62% 9) (8.53% 5) (8.46% 1) (8.44% 8) (8.25% 4) (8.21% 2) (8.18% 6) (8.15% 7) (7.57% 3)) |}] ;; let nativeint_uniform_inclusive = Generator.nativeint_uniform_inclusive let%expect_test "nativeint_uniform_inclusive" = test_generator (Generator.nativeint_uniform_inclusive 0n 10n) (m_nat' ~up_to:10 (module Nativeint)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.nativeint_uniform_inclusive 0n 10n) (module Nativeint); [%expect {| ((9.55% 5) (9.54% 0) (9.21% 9) (9.18% 1) (9.14% 4) (9.01% 7) (8.95% 10) (8.89% 8) (8.88% 3) (8.86% 2) (8.79% 6)) |}] ;; let nativeint_log_inclusive = Generator.nativeint_log_inclusive let%expect_test "nativeint_log_inclusive" = test_generator (Generator.nativeint_log_inclusive 0n 10n) (m_nat' ~up_to:10 (module Nativeint)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.nativeint_log_inclusive 0n 10n) (module Nativeint); [%expect {| ((22.24% 0) (18.67% 1) (10.43% 10) (9.47% 3) (9.12% 2) (6.03% 8) (6% 9) (4.82% 5) (4.59% 4) (4.37% 7) (4.26% 6)) |}] ;; let nativeint_log_uniform_inclusive = Generator.nativeint_log_uniform_inclusive let%expect_test "nativeint_log_uniform_inclusive" = test_generator (Generator.nativeint_log_uniform_inclusive 0n 10n) (m_nat' ~up_to:10 (module Nativeint)); [%expect {| (generator exhaustive) |}]; show_distribution (Generator.nativeint_log_uniform_inclusive 0n 10n) (module Nativeint); [%expect {| ((19.96% 0) (19.8% 1) (10.19% 3) (9.98% 2) (6.74% 9) (6.64% 8) (6.59% 10) (5.11% 6) (5.08% 5) (5.07% 7) (4.84% 4)) |}] ;; let nativeint_geometric = Generator.nativeint_geometric let%expect_test "nativeint_geometric" = let test n p = let gen = Generator.nativeint_geometric (Nativeint.of_int n) ~p in test_generator gen (m_nat' ~up_to:n (module Nativeint)) ~mode:(if n <= 0 then `exhaustive else `inexhaustive); show_distribution gen (module Nativeint) ~show:4 in (* check that we stay above the lower bound, test sensible distributions *) test 1 0.25; [%expect {| (generator ("generated 29 distinct values in 10_000 iterations" ("did not generate these values" (0)))) ((25.65% 1) (18.97% 2) (14.45% 3) (10.34% 4)) |}]; test 2 0.5; [%expect {| (generator ("generated 14 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((50.77% 2) (25.07% 3) (11.79% 4) (5.78% 5)) |}]; test (-3) 0.75; [%expect {| (generator "generated 8 distinct values in 10_000 iterations") ((75.84% -3) (17.57% -2) (4.97% -1) (1.2% 0)) |}]; (* test a very low [p] *) test 1 Float.min_positive_subnormal_value; expect_test_output [%here] |> replace ~pattern:(Nativeint.to_string Nativeint.max_value) ~with_:"MAX_VALUE" |> print_string; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (0 1)))) ((1x MAX_VALUE)) |}]; (* test bounds checking *) require_does_raise [%here] (fun () -> Generator.nativeint_geometric 0n ~p:Float.nan); [%expect {| ("geometric distribution: p must be between 0 and 1" (p NAN)) |}]; require_does_raise [%here] (fun () -> Generator.nativeint_geometric 0n ~p:(-1.)); [%expect {| ("geometric distribution: p must be between 0 and 1" (p -1)) |}]; require_does_raise [%here] (fun () -> Generator.nativeint_geometric 0n ~p:2.); [%expect {| ("geometric distribution: p must be between 0 and 1" (p 2)) |}] ;; let float = Generator.float let%expect_test "float" = test_generator ~mode:`inexhaustive Generator.float m_float; [%expect {| (generator ("generated 9_127 distinct values in 10_000 iterations" ("did not generate these values" (-1.7976931348623157E+308 1.7976931348623157E+308)))) |}] ;; let float_without_nan = Generator.float_without_nan let%expect_test "float_without_nan" = test_generator ~mode:`inexhaustive Generator.float_without_nan m_float; [%expect {| (generator ("generated 9_170 distinct values in 10_000 iterations" ("did not generate these values" (NAN -1.7976931348623157E+308 1.7976931348623157E+308)))) |}] ;; let float_finite = Generator.float_finite let%expect_test "float_finite" = test_generator ~mode:`inexhaustive Generator.float_finite m_float; [%expect {| (generator ("generated 9_252 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 1.7976931348623157E+308 INF)))) |}] ;; let float_strictly_positive = Generator.float_strictly_positive let%expect_test "float_strictly_positive" = test_generator ~mode:`inexhaustive Generator.float_strictly_positive m_float; [%expect {| (generator ("generated 9_171 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 0 1.7976931348623157E+308 INF)))) |}] ;; let float_strictly_negative = Generator.float_strictly_negative let%expect_test "float_strictly_negative" = test_generator ~mode:`inexhaustive Generator.float_strictly_negative m_float; [%expect {| (generator ("generated 9_171 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 0 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let float_positive_or_zero = Generator.float_positive_or_zero let%expect_test "float_positive_or_zero" = test_generator ~mode:`inexhaustive Generator.float_positive_or_zero m_float; [%expect {| (generator ("generated 9_095 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 1.7976931348623157E+308 INF)))) |}] ;; let float_negative_or_zero = Generator.float_negative_or_zero let%expect_test "float_negative_or_zero" = test_generator ~mode:`inexhaustive Generator.float_negative_or_zero m_float; [%expect {| (generator ("generated 9_095 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let float_inclusive = Generator.float_inclusive let%expect_test "float_inclusive" = test_generator ~mode:`inexhaustive (Generator.float_inclusive (-1.) 1.) m_float; [%expect {| (generator ("generated 9_075 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 0 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let%expect_test "float_inclusive singular range edge case" = test_generator ~mode:`inexhaustive (Generator.float_inclusive 1. 1.) m_float; [%expect {| (generator ("generated 1 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 0 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let%expect_test "float_inclusive two-value range edge case" = show_raise (fun () -> test_generator ~mode:`inexhaustive (Generator.float_inclusive 5000000000000000. 5000000000000001.) m_float); [%expect {| (generator ("generated 2 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 0 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) "did not raise" |}] ;; let float_uniform_exclusive = Generator.float_uniform_exclusive let%expect_test "float_uniform_exclusive" = test_generator ~mode:`inexhaustive (Generator.float_uniform_exclusive (-1.) 1.) m_float; [%expect {| (generator ("generated 10_000 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 -2.2250738585072009E-308 -4.94065645841247E-324 0 4.94065645841247E-324 2.2250738585072009E-308 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let float_of_class = Generator.float_of_class let%expect_test "float_of_class" = test_generator ~mode:`inexhaustive (Generator.float_of_class Normal) m_float; [%expect {| (generator ("generated 9_360 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072009E-308 -4.94065645841247E-324 0 4.94065645841247E-324 2.2250738585072009E-308 1.7976931348623157E+308 INF)))) |}]; test_generator ~mode:`inexhaustive (Generator.float_of_class Subnormal) m_float; [%expect {| (generator ("generated 7_852 distinct values in 10_000 iterations" ("did not generate these values" (NAN -INF -1.7976931348623157E+308 -2.2250738585072014E-308 0 2.2250738585072014E-308 1.7976931348623157E+308 INF)))) |}] ;; let char = Generator.char let%expect_test "char" = test_generator Generator.char m_char; [%expect {| (generator "generated 249 distinct values in 10_000 iterations") |}] ;; let char_lowercase = Generator.char_lowercase let%expect_test "char_lowercase" = test_generator ~mode:`inexhaustive Generator.char_lowercase m_char; [%expect {| (generator ("generated 26 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! 0 9 A Z ~ "\255")))) |}] ;; let char_uppercase = Generator.char_uppercase let%expect_test "char_uppercase" = test_generator ~mode:`inexhaustive Generator.char_uppercase m_char; [%expect {| (generator ("generated 26 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! 0 9 a z ~ "\255")))) |}] ;; let char_digit = Generator.char_digit let%expect_test "char_digit" = test_generator ~mode:`inexhaustive Generator.char_digit m_char; [%expect {| (generator ("generated 10 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! A Z a z ~ "\255")))) |}] ;; let char_alpha = Generator.char_alpha let%expect_test "char_alpha" = test_generator ~mode:`inexhaustive Generator.char_alpha m_char; [%expect {| (generator ("generated 52 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! 0 9 ~ "\255")))) |}] ;; let char_alphanum = Generator.char_alphanum let%expect_test "char_alphanum" = test_generator ~mode:`inexhaustive Generator.char_alphanum m_char; [%expect {| (generator ("generated 62 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! ~ "\255")))) |}] ;; let char_whitespace = Generator.char_whitespace let%expect_test "char_whitespace" = test_generator ~mode:`inexhaustive Generator.char_whitespace m_char; [%expect {| (generator ("generated 6 distinct values in 10_000 iterations" ("did not generate these values" ("\000" ! 0 9 A Z a z ~ "\255")))) |}] ;; let char_print = Generator.char_print let%expect_test "char_print" = test_generator ~mode:`inexhaustive Generator.char_print m_char; [%expect {| (generator ("generated 95 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" "\255")))) |}] ;; let char_uniform_inclusive = Generator.char_uniform_inclusive let%expect_test "char_uniform_inclusive" = test_generator ~mode:`inexhaustive (Generator.char_uniform_inclusive 'A' 'Z') m_char; [%expect {| (generator ("generated 26 distinct values in 10_000 iterations" ("did not generate these values" ("\000" "\t" " " ! 0 9 a z ~ "\255")))) |}] ;; let string = Generator.string let%expect_test "string" = test_generator ~mode:`inexhaustive Generator.string m_string; [%expect {| (generator ("generated 8_583 distinct values in 10_000 iterations" ("did not generate these values" (" " "\000\000" " " 00 AA __ zz)))) |}] ;; let string_non_empty = Generator.string_non_empty let%expect_test "string_non_empty" = test_generator ~mode:`inexhaustive Generator.string_non_empty m_string; [%expect {| (generator ("generated 8_936 distinct values in 10_000 iterations" ("did not generate these values" ("" " " "\000\000" " " 00 AA __ zz)))) |}] ;; let string_with_length = Generator.string_with_length let%expect_test "string_with_length" = test_generator ~mode:`inexhaustive (Generator.string_with_length ~length:2) m_string; [%expect {| (generator ("generated 5_239 distinct values in 10_000 iterations" ("did not generate these values" ("" "\000" " " 0 A _ z "\000\000" " " __)))) |}] ;; let string_of = Generator.string_of let%expect_test "string_of" = test_generator ~mode:`inexhaustive (Generator.string_of (Generator.filter Generator.char ~f:Char.is_lowercase)) m_string; [%expect {| (generator ("generated 8_320 distinct values in 10_000 iterations" ("did not generate these values" ("\000" " " 0 A _ "\000\000" " " 00 AA __)))) |}] ;; let string_non_empty_of = Generator.string_non_empty_of let%expect_test "string_non_empty_of" = test_generator ~mode:`inexhaustive (Generator.string_non_empty_of (Generator.filter Generator.char ~f:Char.is_lowercase)) m_string; [%expect {| (generator ("generated 8_569 distinct values in 10_000 iterations" ("did not generate these values" ("" "\000" " " 0 A _ "\000\000" " " 00 AA __ zz)))) |}] ;; let string_with_length_of = Generator.string_with_length_of let%expect_test "string_with_length_of" = test_generator ~mode:`inexhaustive (Generator.string_with_length_of ~length:2 (Generator.filter Generator.char ~f:Char.is_lowercase)) m_string; [%expect {| (generator ("generated 676 distinct values in 10_000 iterations" ("did not generate these values" ("" "\000" " " 0 A _ z "\000\000" " " 00 AA __)))) |}] ;; let string_like = Generator.string_like let%expect_test "string_like" = test_generator ~mode:`inexhaustive (Generator.string_like "__") m_string; [%expect {| (generator ("generated 2_643 distinct values in 10_000 iterations" ("did not generate these values" (" " "\000\000" " " 00)))) |}]; Test.with_sample_exn (Generator.string_like "The quick brown fox jumps over the lazy dog.") ~f:(fun sequence -> Sequence.take sequence 30 |> Sequence.iter ~f:(fun string -> print_s (sexp_of_string string))); [%expect {| "The quick uick brown fox jumps over the lazy dog." "The quickdog." "The quick brownThe quick brown fox jumps over the lazy dog." . "The quick brown fmps over the lazy dog." "The quick brown fox jumps over the lazy dog./" "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown jumps over the lazy dog." "The ThOHQuJyXVs8 TThOHQuXVs8gcTe\255P\000xv\134uV\197p2qysr7fAzjbAWyMdog." "The quick brown fox jumps over the lazy dog." "The quickL brown fox jdJ=3umps over the lazy dog." "The quick brown fox jumps over the lazy dog.brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over tox jumps jumps over tox jumps over the lazy dI7bog." "The quick brownzy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "ThbgX\171e quuick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps HjvQyI1e lazy dog." "The quick brown fox jumps over the lazy dog." "The quick brown fox jumps ov jumps over the lazy dog." "TOe quick brown fox jm|tumps over thethe lazy dog." "\\\003DuRB9A4O8p~OUoHsP6e\255C44ZQROn4\164ru\03104FN\144wMhD" "tg9+W3saM\173ZkL;3KDi\\tmSUMwxY6Y\"PLkM27]fXyN9,'" "The quick brown fox jumps over the lazy dog." |}] ;; let bytes = Generator.bytes let%expect_test "bytes" = test_generator ~mode:`inexhaustive Generator.bytes m_bytes; [%expect {| (generator ("generated 8_583 distinct values in 10_000 iterations" ("did not generate these values" (" " "\000\000" " " 00 AA __ zz)))) |}] ;; let sexp = Generator.sexp let%expect_test "sexp" = test_generator ~mode:`inexhaustive Generator.sexp m_sexp; [%expect {| (generator ("generated 7_175 distinct values in 10_000 iterations" ("did not generate these values" (bc def (a bc def) (a bc def (a) (bc) (def) (a bc def)) (bc) (def))))) |}] ;; let sexp_of = Generator.sexp_of let%expect_test "sexp_of" = test_generator ~mode:`inexhaustive (Generator.sexp_of (Generator.of_list [ "a"; "bc"; "def" ])) m_sexp; [%expect {| (generator ("generated 4_917 distinct values in 10_000 iterations" ("did not generate these values" ((a bc def) (a bc def (a) (bc) (def) (a bc def)))))) |}] ;; let list = Generator.list let%expect_test "list" = test_generator (Generator.list Generator.bool) (m_list m_bool); [%expect {| (generator "generated 2_248 distinct values in 10_000 iterations") |}] ;; let list_non_empty = Generator.list_non_empty let%expect_test "list_non_empty" = test_generator ~mode:`inexhaustive (Generator.list_non_empty Generator.bool) (m_list m_bool); [%expect {| (generator ("generated 2_672 distinct values in 10_000 iterations" ("did not generate these values" (())))) |}] ;; let list_with_length = Generator.list_with_length let%expect_test "list_with_length" = test_generator ~mode:`inexhaustive (Generator.list_with_length ~length:2 Generator.bool) (m_list m_bool); [%expect {| (generator ("generated 4 distinct values in 10_000 iterations" ("did not generate these values" (() (false) (true))))) |}] ;; let list_filtered = Generator.list_filtered let%expect_test "list_filtered" = let original_list = List.range 1 4 ~start:`inclusive ~stop:`inclusive in test_generator (Generator.list_filtered original_list) (module struct type t = int list [@@deriving compare, sexp_of] let examples = [ [] ] @ List.map original_list ~f:List.return @ [ original_list ] end); [%expect {| (generator "generated 16 distinct values in 10_000 iterations") |}] ;; let list_permutations = Generator.list_permutations let%expect_test "list_permutations" = let original_list = List.range 1 4 ~start:`inclusive ~stop:`inclusive in test_generator (Generator.list_permutations original_list) (module struct type t = int list [@@deriving compare, sexp_of] let examples = [ original_list; List.rev original_list ] end); [%expect {| (generator "generated 24 distinct values in 10_000 iterations") |}] ;; let array = Generator.array let%expect_test "array" = test_generator (Generator.array Generator.bool) (m_array m_bool); [%expect {| (generator "generated 2_248 distinct values in 10_000 iterations") |}] ;; let ref = Generator.ref let%expect_test "ref" = test_generator (Generator.ref Generator.bool) (m_ref m_bool); [%expect {| (generator exhaustive) |}] ;; let lazy_t = Generator.lazy_t let%expect_test "lazy_t" = test_generator (Generator.lazy_t Generator.bool) (m_lazy_t m_bool); [%expect {| (generator exhaustive) |}] ;; let of_lazy = Generator.of_lazy let%expect_test "of_lazy, forced" = test_generator (Generator.of_lazy (lazy Generator.size)) (m_nat ~up_to:30); [%expect {| (generator exhaustive) |}] ;; let%expect_test "of_lazy, unforced" = test_generator (Generator.weighted_union [ Float.max_finite_value, Generator.size ; Float.min_positive_subnormal_value, Generator.of_lazy (lazy (assert false)) ]) (m_nat ~up_to:30); [%expect {| (generator exhaustive) |}] ;; let bigarray1 = Generator.bigarray1 let bigstring = Generator.bigstring let float32_vec = Generator.float32_vec let float64_vec = Generator.float64_vec let%expect_test "[bigarray1], [bigstring], [float32_vec], [float64_vec]" = let test (type elt pack layout) (t : (elt, pack, layout) Bigarray.Array1.t Generator.t) sexp_of_elt = let module M = struct type t = (elt, pack, layout) Bigarray.Array1.t let compare = Poly.compare let sexp_of_t = [%sexp_of: (elt, _, _) Private.Bigarray_helpers.Array1.t] let examples = [] end in test_generator t (module M) in test (bigarray1 float Bigarray.float64 Bigarray.c_layout ~length:None) [%sexp_of: float]; [%expect {| (generator "generated 7_520 distinct values in 10_000 iterations") |}]; test (bigarray1 float Bigarray.float32 Bigarray.fortran_layout ~length:(Some 3)) [%sexp_of: float]; [%expect {| (generator "generated 9_525 distinct values in 10_000 iterations") |}]; test bigstring [%sexp_of: char]; [%expect {| (generator "generated 5_751 distinct values in 10_000 iterations") |}]; test float32_vec [%sexp_of: float]; [%expect {| (generator "generated 6_670 distinct values in 10_000 iterations") |}]; test float64_vec [%sexp_of: float]; [%expect {| (generator "generated 7_520 distinct values in 10_000 iterations") |}] ;; let bigstring_with_length = Generator.bigstring_with_length let float32_vec_with_length = Generator.float32_vec_with_length let float64_vec_with_length = Generator.float64_vec_with_length let%expect_test "[bigstring_with_length], [float32_vec_with_length], \ [float64_vec_with_length]" = let test t = let with_length = let open Generator.Let_syntax in let%bind length = Generator.small_positive_or_zero_int in let%map arr = t ~length in arr, length in Test.with_sample_exn with_length ~f: (Sequence.iter ~f:(fun (sample, expected_length) -> Expect_test_helpers_base.require_equal [%here] (module Int) (Bigarray.Array1.dim sample) expected_length)) in test bigstring_with_length; [%expect {| |}]; test float32_vec_with_length; [%expect {| |}]; test float64_vec_with_length; [%expect {| |}] ;; let float32_mat = Generator.float32_mat let float64_mat = Generator.float64_mat let%expect_test "[float32_mat], [float64_mat]" = let test (type elt pack layout) (t : (elt, pack, layout) Bigarray.Array2.t Generator.t) sexp_of_elt = let module M = struct type t = (elt, pack, layout) Bigarray.Array2.t let compare = Poly.compare let sexp_of_t = [%sexp_of: (elt, _, _) Private.Bigarray_helpers.Array2.t] let examples = [] end in test_generator t (module M) in test float32_mat [%sexp_of: float]; [%expect {| (generator "generated 6_875 distinct values in 10_000 iterations") |}]; test float64_mat [%sexp_of: float]; [%expect {| (generator "generated 7_022 distinct values in 10_000 iterations") |}] ;; module Debug = struct let coverage = Generator.Debug.coverage let%expect_test "[coverage]" = let test config = Generator.string_of (Generator.return '.') |> Test.with_sample_exn ~config ~f:(fun sample -> let counts = coverage (module Int) (Sequence.map sample ~f:String.length) in counts |> [%sexp_of: int Map.M(Int).t] |> print_s) in (* small sample size *) test { config with test_count = 3 }; [%expect {| ((0 1) (1 1) (3 1)) |}]; (* larger sample size *) test { config with test_count = 10 }; [%expect {| ((0 2) (1 2) (2 1) (3 1) (4 2) (6 1) (10 1)) |}]; (* nonstandard sizes *) test { config with sizes = Sequence.cycle_list_exn [ 1; 2 ] }; [%expect {| ((0 2466) (1 2534) (2 3304) (3 1696)) |}]; (* not enough sizes *) require_does_raise [%here] (fun () -> test { config with sizes = Sequence.init 10 ~f:Fn.id }); [%expect {| ("Base_quickcheck.Test.run: insufficient size values for test count" (test_count 10000) (number_of_size_values 10)) |}] ;; let monitor = Generator.Debug.monitor let%expect_test "[iter]" = let before = Base.ref 0 in let after = Base.ref 0 in let test n ~f = let t = bool |> monitor ~f:(fun _ -> Int.incr before) |> Generator.filter ~f |> monitor ~f:(fun _ -> Int.incr after) in Test.with_sample_exn t ~config:{ config with test_count = n } ~f:(Sequence.iter ~f:ignore); print_s [%message "counts" (before : int ref) (after : int ref)] in let all (_ : bool) = true in let half bool = bool in test 10 ~f:all; [%expect {| (counts (before 10) (after 10)) |}]; (* state must be reset manually *) test 10 ~f:all; [%expect {| (counts (before 20) (after 20)) |}]; before := 0; test 0 ~f:all; [%expect {| (counts (before 0) (after 20)) |}]; after := 0; test 0 ~f:all; [%expect {| (counts (before 0) (after 0)) |}]; (* [iter] reflects internal behavior such as filtering *) test 10 ~f:half; [%expect {| (counts (before 16) (after 10)) |}] ;; end base_quickcheck-0.17.1/test/src/test_generator.mli000066400000000000000000000000611501616613400222020ustar00rootroot00000000000000include module type of Base_quickcheck.Generator base_quickcheck-0.17.1/test/src/test_observer.ml000066400000000000000000000175551501616613400217120ustar00rootroot00000000000000open! Import type 'a t = 'a Observer.t let create = Observer.create let observe = Observer.observe let%expect_test ("observe & create" [@tags "64-bits-only"]) = let obs = Observer.create (fun x ~size ~hash -> hash_fold_int hash (* make sure to use [size] so we can tell it is threaded in properly *) (Int.min x size)) in List.init 10 ~f:(fun size -> Observer.observe obs 6 ~size ~hash:(Hash.alloc ()) |> Hash.get_hash_value) |> [%sexp_of: int list] |> print_s; [%expect {| (1058613066 129913994 462777137 883721435 607293368 648017920 809201503 809201503 809201503 809201503) |}] ;; let opaque = Observer.opaque let%expect_test "opaque" = test_observer ~mode:`opaque Observer.opaque (m_nat ~up_to:10); [%expect {| (observer opaque) |}] ;; let unmap = Observer.unmap let%expect_test "unmap" = test_observer (Observer.unmap Observer.int64 ~f:Int.to_int64) (m_int (module Int)); [%expect {| (observer transparent) |}] ;; let of_hash_fold = Observer.of_hash_fold let%expect_test "of_hash_fold" = test_observer (Observer.of_hash_fold Sexp.hash_fold_t) m_sexp; [%expect {| (observer transparent) |}] ;; let fixed_point = Observer.fixed_point let%expect_test "fixed_point" = test_observer (Observer.fixed_point (fun observer -> Observer.unmap (Observer.option observer) ~f:(function | 0 -> None | n -> Some (n - 1)))) (m_nat ~up_to:10); [%expect {| (observer transparent) |}] ;; let fn = Observer.fn let%expect_test "fn" = let config = { Test.default_config with test_count = 100 } in let first_order = m_arrow m_bool m_bool in let (module First_order) = first_order in test_observer ~config (Observer.fn Generator.bool Observer.bool) first_order; [%expect {| (observer transparent) |}]; print_s [%sexp (First_order.examples : First_order.t list)]; [%expect {| (((false false) (true false)) ((false false) (true true)) ((false true) (true false)) ((false true) (true true))) |}]; let higher_order = m_arrow first_order m_bool in let (module _) = higher_order in test_observer ~config (Observer.fn (Generator.fn Observer.bool Generator.bool) Observer.bool) higher_order; [%expect {| (observer transparent) |}] ;; let both = Observer.both let%expect_test "both" = test_observer (Observer.both Observer.bool Observer.bool) (m_pair m_bool m_bool); [%expect {| (observer transparent) |}] ;; let unit = Observer.unit let%expect_test "unit" = test_observer Observer.unit m_unit; [%expect {| (observer transparent) |}] ;; let bool = Observer.bool let%expect_test "bool" = test_observer Observer.bool m_bool; [%expect {| (observer transparent) |}] ;; let char = Observer.char let%expect_test "char" = test_observer Observer.char m_char; [%expect {| (observer transparent) |}] ;; let string = Observer.string let%expect_test "string" = test_observer Observer.string m_string; [%expect {| (observer transparent) |}] ;; let bytes = Observer.bytes let%expect_test "bytes" = test_observer Observer.bytes m_bytes; [%expect {| (observer transparent) |}] ;; let int = Observer.int let%expect_test "int" = test_observer Observer.int (m_int (module Int)); [%expect {| (observer transparent) |}] ;; let int32 = Observer.int32 let%expect_test ("int32" [@tags "64-bits-only"]) = test_observer Observer.int32 (m_int (module Int32)); [%expect {| (observer transparent) |}] ;; let int63 = Observer.int63 let%expect_test "int63" = test_observer Observer.int63 (m_int (module Int63)); [%expect {| (observer transparent) |}] ;; let int64 = Observer.int64 let%expect_test "int64" = test_observer Observer.int64 (m_int (module Int64)); [%expect {| (observer transparent) |}] ;; let nativeint = Observer.nativeint let%expect_test "nativeint" = test_observer Observer.nativeint (m_int (module Nativeint)); [%expect {| (observer transparent) |}] ;; let float = Observer.float let%expect_test "float" = test_observer Observer.float m_float; [%expect {| (observer transparent) |}] ;; let sexp = Observer.sexp let%expect_test "sexp" = test_observer Observer.sexp m_sexp; [%expect {| (observer transparent) |}] ;; let option = Observer.option let%expect_test "option" = [%expect {| |}]; test_observer (Observer.option Observer.bool) (m_option m_bool); [%expect {| (observer transparent) |}] ;; let list = Observer.list let%expect_test "list" = test_observer (Observer.list Observer.bool) (m_list m_bool); [%expect {| (observer transparent) |}] ;; let array = Observer.array let%expect_test "array" = test_observer (Observer.array Observer.bool) (m_array m_bool); [%expect {| (observer transparent) |}] ;; let ref = Observer.ref let%expect_test "ref" = test_observer (Observer.ref Observer.bool) (m_ref m_bool); [%expect {| (observer transparent) |}] ;; let lazy_t = Observer.lazy_t let%expect_test "lazy_t" = test_observer (Observer.lazy_t Observer.bool) (m_lazy_t m_bool); [%expect {| (observer transparent) |}] ;; let either = Observer.either let%expect_test "either" = test_observer (Observer.either Observer.bool Observer.bool) (m_either m_bool m_bool); [%expect {| (observer transparent) |}] ;; let result = Observer.result let%expect_test "result" = test_observer (Observer.result Observer.bool Observer.bool) (m_result m_bool m_bool); [%expect {| (observer transparent) |}] ;; let map_t = Observer.map_t let map_tree = Observer.map_tree let%expect_test "map_t" = test_observer (Observer.map_t Observer.bool Observer.bool) (m_map (module Bool) m_bool m_bool); [%expect {| (observer transparent) |}] ;; let set_t = Observer.set_t let set_tree = Observer.set_tree let%expect_test "set_t" = test_observer (Observer.set_t Observer.bool) (m_set (module Bool) m_bool); [%expect {| (observer transparent) |}] ;; let of_lazy = Observer.of_lazy let%expect_test "of_lazy, forced" = test_observer (Observer.of_lazy (lazy Observer.string)) m_string; [%expect {| (observer transparent) |}] ;; let%expect_test "of_lazy, unforced" = test_observer (Observer.either Observer.string (Observer.of_lazy (lazy (assert false)))) (m_biject m_string ~f:(fun string -> Either.First string) ~f_inverse:(function | Either.First string -> string | Either.Second (_ : Nothing.t) -> .)); [%expect {| (observer transparent) |}] ;; let bigstring = Observer.bigstring let%expect_test "[bigstring]" = test_observer Observer.bigstring (m_biject m_string ~f:Base_bigstring.of_string ~f_inverse:Base_bigstring.to_string); [%expect {| (observer transparent) |}] ;; let float32_vec = Observer.float32_vec let float64_vec = Observer.float64_vec let%expect_test "[float32_vec], [float64_vec]" = let test observer kind = (module struct include (val m_float) let examples = [ 1.; -1.; Float.nan ] end) |> m_list |> m_biject ~f:Array.of_list ~f_inverse:Array.to_list |> m_biject ~f:(Bigarray.Array1.of_array kind Fortran_layout) ~f_inverse:Private.Bigarray_helpers.Array1.to_array |> test_observer observer in test float32_vec Float32; [%expect {| (observer transparent) |}]; test float64_vec Float64; [%expect {| (observer transparent) |}] ;; let float32_mat = Observer.float32_mat let float64_mat = Observer.float64_mat let%expect_test "[float32_mat], [float64_mat]" = let test observer kind = (module struct type t = float array array [@@deriving compare, sexp_of] let examples = [ [||]; [| [| 0. |] |]; [| [| 0.; 1. |] |]; [| [| 0. |]; [| 1. |] |] ] ;; end) |> m_biject ~f:(Bigarray.Array2.of_array kind Fortran_layout) ~f_inverse:Private.Bigarray_helpers.Array2.to_array |> test_observer observer in test float32_mat Float32; [%expect {| (observer transparent) |}]; test float64_mat Float64; [%expect {| (observer transparent) |}] ;; base_quickcheck-0.17.1/test/src/test_observer.mli000066400000000000000000000000601501616613400220420ustar00rootroot00000000000000include module type of Base_quickcheck.Observer base_quickcheck-0.17.1/test/src/test_shrinker.ml000066400000000000000000000423141501616613400216770ustar00rootroot00000000000000open! Import module Example = struct let natural_number_shrinker = Shrinker.create (function | 0 -> Sequence.empty | n -> Sequence.singleton (n - 1)) ;; end open Example type 'a t = 'a Shrinker.t let create = Shrinker.create let shrink = Shrinker.shrink let%expect_test "create & shrink" = List.init 10 ~f:(fun size -> size, Shrinker.shrink natural_number_shrinker size) |> [%sexp_of: (int * int Sequence.t) list] |> print_s; [%expect {| ((0 ()) (1 (0)) (2 (1)) (3 (2)) (4 (3)) (5 (4)) (6 (5)) (7 (6)) (8 (7)) (9 (8))) |}] ;; let atomic = Shrinker.atomic let%expect_test "atomic" = test_shrinker ~mode:`atomic Shrinker.atomic m_bool; [%expect {| (shrinker atomic) |}] ;; let map = Shrinker.map let%expect_test "shrinker" = test_shrinker (Shrinker.map natural_number_shrinker ~f:Int.pred ~f_inverse:Int.succ) (m_nat ~up_to:10); [%expect {| (shrinker ((0 => -1) (1 => 0) (2 => 1) (3 => 2) (4 => 3) (5 => 4) (6 => 5) (7 => 6) (8 => 7) (9 => 8) (10 => 9))) |}] ;; let filter = Shrinker.filter let%expect_test "shrinker" = test_shrinker (Shrinker.filter (Shrinker.list natural_number_shrinker) ~f:(fun list -> not (List.is_empty list))) (m_list (m_nat ~up_to:3)); [%expect {| (shrinker (((1) => (0)) ((2) => (1)) ((3) => (2)) ((0 3) => (3)) ((0 3) => (0)) ((0 3) => (0 2)) ((1 2) => (2)) ((1 2) => (0 2)) ((1 2) => (1)) ((1 2) => (1 1)) ((2 1) => (1)) ((2 1) => (1 1)) ((2 1) => (2)) ((2 1) => (2 0)) ((3 0) => (0)) ((3 0) => (2 0)) ((3 0) => (3)))) |}] ;; let filter_map = Shrinker.filter_map let%expect_test "shrinker" = test_shrinker (Shrinker.filter_map (Shrinker.list natural_number_shrinker) ~f:(function | [] -> None | list -> Some (List.map list ~f:Int.pred)) ~f_inverse:(List.map ~f:Int.succ)) (m_list (m_nat ~up_to:3)); [%expect {| (shrinker (((0) => (-1)) ((1) => (0)) ((2) => (1)) ((3) => (2)) ((0 3) => (3)) ((0 3) => (-1 3)) ((0 3) => (0)) ((0 3) => (0 2)) ((1 2) => (2)) ((1 2) => (0 2)) ((1 2) => (1)) ((1 2) => (1 1)) ((2 1) => (1)) ((2 1) => (1 1)) ((2 1) => (2)) ((2 1) => (2 0)) ((3 0) => (0)) ((3 0) => (2 0)) ((3 0) => (3)) ((3 0) => (3 -1)))) |}] ;; let fixed_point = Shrinker.fixed_point let%expect_test "fixed_point" = test_shrinker (Shrinker.fixed_point (fun shrinker -> Shrinker.map (Shrinker.option shrinker) ~f:(function | None -> 0 | Some n -> n + 1) ~f_inverse:(function | 0 -> None | n -> Some (n - 1)))) (m_nat ~up_to:4); [%expect {| (shrinker ((1 => 0) (2 => 0) (2 => 1) (3 => 0) (3 => 1) (3 => 2) (4 => 0) (4 => 1) (4 => 2) (4 => 3))) |}] ;; let both = Shrinker.both let%expect_test "both" = test_shrinker (Shrinker.both natural_number_shrinker natural_number_shrinker) (m_pair (m_nat ~up_to:4) (m_nat ~up_to:4)); [%expect {| (shrinker (((0 1) => (0 0)) ((0 2) => (0 1)) ((0 3) => (0 2)) ((0 4) => (0 3)) ((1 0) => (0 0)) ((1 1) => (0 1)) ((1 1) => (1 0)) ((1 2) => (0 2)) ((1 2) => (1 1)) ((1 3) => (0 3)) ((1 3) => (1 2)) ((1 4) => (0 4)) ((1 4) => (1 3)) ((2 0) => (1 0)) ((2 1) => (1 1)) ((2 1) => (2 0)) ((2 2) => (1 2)) ((2 2) => (2 1)) ((2 3) => (1 3)) ((2 3) => (2 2)) ((2 4) => (1 4)) ((2 4) => (2 3)) ((3 0) => (2 0)) ((3 1) => (2 1)) ((3 1) => (3 0)) ((3 2) => (2 2)) ((3 2) => (3 1)) ((3 3) => (2 3)) ((3 3) => (3 2)) ((3 4) => (2 4)) ((3 4) => (3 3)) ((4 0) => (3 0)) ((4 1) => (3 1)) ((4 1) => (4 0)) ((4 2) => (3 2)) ((4 2) => (4 1)) ((4 3) => (3 3)) ((4 3) => (4 2)) ((4 4) => (3 4)) ((4 4) => (4 3)))) |}] ;; let unit = Shrinker.unit let%expect_test "unit" = test_shrinker ~mode:`atomic Shrinker.unit m_unit; [%expect {| (shrinker atomic) |}] ;; let bool = Shrinker.bool let%expect_test "bool" = test_shrinker ~mode:`atomic Shrinker.bool m_bool; [%expect {| (shrinker atomic) |}] ;; let char = Shrinker.char let%expect_test "char" = test_shrinker ~mode:`atomic Shrinker.char m_char; [%expect {| (shrinker atomic) |}] ;; let string = Shrinker.string let%expect_test "string" = test_shrinker Shrinker.string m_string; [%expect {| (shrinker ((A => "") (z => "") (0 => "") (_ => "") (" " => "") ("\000" => "") (AA => A) (AA => A) (zz => z) (zz => z) (00 => 0) (00 => 0) (__ => _) (__ => _) (" " => " ") (" " => " ") ("\000\000" => "\000") ("\000\000" => "\000"))) |}] ;; let bytes = Shrinker.bytes let%expect_test "bytes" = test_shrinker Shrinker.bytes m_bytes; [%expect {| (shrinker (("\000" => "") (" " => "") (0 => "") (A => "") (_ => "") (z => "") ("\000\000" => "\000") ("\000\000" => "\000") (" " => " ") (" " => " ") (00 => 0) (00 => 0) (AA => A) (AA => A) (__ => _) (__ => _) (zz => z) (zz => z))) |}] ;; let int = Shrinker.int let%expect_test "int" = test_shrinker ~mode:`atomic Shrinker.int (m_int (module Int)); [%expect {| (shrinker atomic) |}] ;; let int32 = Shrinker.int32 let%expect_test "int32" = test_shrinker ~mode:`atomic Shrinker.int32 (m_int (module Int32)); [%expect {| (shrinker atomic) |}] ;; let int63 = Shrinker.int63 let%expect_test "int63" = test_shrinker ~mode:`atomic Shrinker.int63 (m_int (module Int63)); [%expect {| (shrinker atomic) |}] ;; let int64 = Shrinker.int64 let%expect_test "int64" = test_shrinker ~mode:`atomic Shrinker.int64 (m_int (module Int64)); [%expect {| (shrinker atomic) |}] ;; let nativeint = Shrinker.nativeint let%expect_test "nativeint" = test_shrinker ~mode:`atomic Shrinker.nativeint (m_int (module Nativeint)); [%expect {| (shrinker atomic) |}] ;; let float = Shrinker.float let%expect_test "float" = test_shrinker ~mode:`atomic Shrinker.float m_float; [%expect {| (shrinker atomic) |}] ;; let sexp = Shrinker.sexp let%expect_test "sexp" = test_shrinker Shrinker.sexp m_sexp; [%expect {| (shrinker (((a) => ()) ((a) => a) ((bc) => ()) ((bc) => bc) ((def) => ()) ((def) => def) ((a bc def) => (bc def)) ((a bc def) => a) ((a bc def) => (a def)) ((a bc def) => bc) ((a bc def) => (a bc)) ((a bc def) => def) ((a bc def (a) (bc) (def) (a bc def)) => (bc def (a) (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => a) ((a bc def (a) (bc) (def) (a bc def)) => (a def (a) (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => bc) ((a bc def (a) (bc) (def) (a bc def)) => (a bc (a) (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => def) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def () (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (bc)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (def)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def a (bc) (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) () (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) bc (def) (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) () (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) def (a bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) (bc def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) a)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) (a def))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) bc)) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) (a bc))) ((a bc def (a) (bc) (def) (a bc def)) => (a bc def (a) (bc) (def) def)))) |}] ;; let option = Shrinker.option let%expect_test "option" = test_shrinker (Shrinker.option natural_number_shrinker) (m_option (m_nat ~up_to:4)); [%expect {| (shrinker (((0) => ()) ((1) => ()) ((1) => (0)) ((2) => ()) ((2) => (1)) ((3) => ()) ((3) => (2)) ((4) => ()) ((4) => (3)))) |}] ;; let list = Shrinker.list let%expect_test "list" = test_shrinker (Shrinker.list natural_number_shrinker) (m_list (m_nat ~up_to:4)); [%expect {| (shrinker (((0) => ()) ((1) => ()) ((1) => (0)) ((2) => ()) ((2) => (1)) ((3) => ()) ((3) => (2)) ((4) => ()) ((4) => (3)) ((0 4) => (4)) ((0 4) => (0)) ((0 4) => (0 3)) ((1 3) => (3)) ((1 3) => (0 3)) ((1 3) => (1)) ((1 3) => (1 2)) ((2 2) => (2)) ((2 2) => (1 2)) ((2 2) => (2)) ((2 2) => (2 1)) ((3 1) => (1)) ((3 1) => (2 1)) ((3 1) => (3)) ((3 1) => (3 0)) ((4 0) => (0)) ((4 0) => (3 0)) ((4 0) => (4)))) |}] ;; let array = Shrinker.array let%expect_test "array" = test_shrinker (Shrinker.array natural_number_shrinker) (m_array (m_nat ~up_to:4)); [%expect {| (shrinker (((0) => ()) ((1) => ()) ((1) => (0)) ((2) => ()) ((2) => (1)) ((3) => ()) ((3) => (2)) ((4) => ()) ((4) => (3)) ((0 4) => (4)) ((0 4) => (0)) ((0 4) => (0 3)) ((1 3) => (3)) ((1 3) => (0 3)) ((1 3) => (1)) ((1 3) => (1 2)) ((2 2) => (2)) ((2 2) => (1 2)) ((2 2) => (2)) ((2 2) => (2 1)) ((3 1) => (1)) ((3 1) => (2 1)) ((3 1) => (3)) ((3 1) => (3 0)) ((4 0) => (0)) ((4 0) => (3 0)) ((4 0) => (4)))) |}] ;; let ref = Shrinker.ref let%expect_test "ref" = test_shrinker (Shrinker.ref natural_number_shrinker) (m_ref (m_nat ~up_to:4)); [%expect {| (shrinker ((1 => 0) (2 => 1) (3 => 2) (4 => 3))) |}] ;; let lazy_t = Shrinker.lazy_t let%expect_test "lazy_t" = test_shrinker (Shrinker.lazy_t natural_number_shrinker) (m_lazy_t (m_nat ~up_to:4)); [%expect {| (shrinker ((1 => 0) (2 => 1) (3 => 2) (4 => 3))) |}] ;; let either = Shrinker.either let%expect_test "either" = test_shrinker (Shrinker.either natural_number_shrinker natural_number_shrinker) (m_either (m_nat ~up_to:4) (m_nat ~up_to:4)); [%expect {| (shrinker (((First 1) => (First 0)) ((First 2) => (First 1)) ((First 3) => (First 2)) ((First 4) => (First 3)) ((Second 1) => (Second 0)) ((Second 2) => (Second 1)) ((Second 3) => (Second 2)) ((Second 4) => (Second 3)))) |}] ;; let result = Shrinker.result let%expect_test "result" = test_shrinker (Shrinker.result natural_number_shrinker natural_number_shrinker) (m_result (m_nat ~up_to:4) (m_nat ~up_to:4)); [%expect {| (shrinker (((Ok 1) => (Ok 0)) ((Ok 2) => (Ok 1)) ((Ok 3) => (Ok 2)) ((Ok 4) => (Ok 3)) ((Error 1) => (Error 0)) ((Error 2) => (Error 1)) ((Error 3) => (Error 2)) ((Error 4) => (Error 3)))) |}] ;; let map_t = Shrinker.map_t let map_tree_using_comparator = Shrinker.map_tree_using_comparator let%expect_test "map_t" = test_shrinker (Shrinker.map_t natural_number_shrinker natural_number_shrinker) (m_map (module Int) (m_nat ~up_to:2) (m_nat ~up_to:2)); [%expect {| (shrinker ((((0 0) (1 0) (2 0)) => ((1 0) (2 0))) (((0 0) (1 0) (2 0)) => ((0 0) (2 0))) (((0 0) (1 0) (2 0)) => ((0 0) (1 0))) (((0 1) (1 1) (2 1)) => ((1 1) (2 1))) (((0 1) (1 1) (2 1)) => ((0 0) (1 1) (2 1))) (((0 1) (1 1) (2 1)) => ((0 1) (2 1))) (((0 1) (1 1) (2 1)) => ((0 1) (1 0) (2 1))) (((0 1) (1 1) (2 1)) => ((0 1) (1 1))) (((0 1) (1 1) (2 1)) => ((0 1) (1 1) (2 0))) (((0 2) (1 2) (2 2)) => ((1 2) (2 2))) (((0 2) (1 2) (2 2)) => ((0 1) (1 2) (2 2))) (((0 2) (1 2) (2 2)) => ((0 2) (2 2))) (((0 2) (1 2) (2 2)) => ((0 2) (1 1) (2 2))) (((0 2) (1 2) (2 2)) => ((0 2) (1 2))) (((0 2) (1 2) (2 2)) => ((0 2) (1 2) (2 1))))) |}] ;; let set_t = Shrinker.set_t let set_tree_using_comparator = Shrinker.set_tree_using_comparator let%expect_test "set_t" = test_shrinker (Shrinker.set_t natural_number_shrinker) (m_set (module Int) (m_nat ~up_to:5)); [%expect {| (shrinker (((0) => ()) ((1) => ()) ((1) => (0)) ((2) => ()) ((2) => (1)) ((3) => ()) ((3) => (2)) ((4) => ()) ((4) => (3)) ((5) => ()) ((5) => (4)) ((0 5) => (5)) ((0 5) => (0 4)) ((0 5) => (0)) ((1 4) => (4)) ((1 4) => (0 4)) ((1 4) => (1)) ((1 4) => (1 3)) ((2 3) => (3)) ((2 3) => (1 3)) ((2 3) => (2)))) |}] ;; let of_lazy = Shrinker.of_lazy let%expect_test "of_lazy, forced" = test_shrinker (Shrinker.of_lazy (lazy Shrinker.string)) m_string; [%expect {| (shrinker ((A => "") (z => "") (0 => "") (_ => "") (" " => "") ("\000" => "") (AA => A) (AA => A) (zz => z) (zz => z) (00 => 0) (00 => 0) (__ => _) (__ => _) (" " => " ") (" " => " ") ("\000\000" => "\000") ("\000\000" => "\000"))) |}] ;; let%expect_test "of_lazy, unforced" = test_shrinker (Shrinker.either Shrinker.string (Shrinker.of_lazy (lazy (assert false)))) (m_biject m_string ~f:(fun string -> Either.First string) ~f_inverse:(function | Either.First string -> string | Either.Second (_ : Nothing.t) -> .)); [%expect {| (shrinker (("\000" => "") (" " => "") (0 => "") (A => "") (_ => "") (z => "") ("\000\000" => "\000") ("\000\000" => "\000") (" " => " ") (" " => " ") (00 => 0) (00 => 0) (AA => A) (AA => A) (__ => _) (__ => _) (zz => z) (zz => z))) |}] ;; let bigstring = Shrinker.bigstring let float32_vec = Shrinker.float32_vec let float64_vec = Shrinker.float64_vec let%expect_test "[bigstring], [float32_vec], [float64_vec]" = let test (type elt pack layout) t sexp_of_elt examples kind layout = let module M = struct type t = (elt, pack, layout) Bigarray.Array1.t let compare = Poly.compare let sexp_of_t = [%sexp_of: (elt, _, _) Private.Bigarray_helpers.Array1.t] let examples = List.init (List.length examples + 1) ~f:(fun n -> List.take examples n |> Array.of_list |> Bigarray.Array1.of_array kind layout) ;; end in test_shrinker t (module M) in test Shrinker.bigstring [%sexp_of: char] [ 'a'; 'b' ] Char C_layout; [%expect {| (shrinker (((a) => ()) ((a b) => (b)) ((a b) => (a)))) |}]; test Shrinker.float32_vec [%sexp_of: float] [ 1.; 2. ] Float32 Fortran_layout; [%expect {| (shrinker (((1) => ()) ((1 2) => (2)) ((1 2) => (1)))) |}]; test Shrinker.float64_vec [%sexp_of: float] [ 1.; 2. ] Float64 Fortran_layout; [%expect {| (shrinker (((1) => ()) ((1 2) => (2)) ((1 2) => (1)))) |}] ;; let float32_mat = Shrinker.float32_mat let float64_mat = Shrinker.float64_mat let%expect_test "[float32_mat]" = let test (type pack) t kind = let module M = struct type t = (float, pack, Bigarray.fortran_layout) Bigarray.Array2.t let compare = Poly.compare let sexp_of_t = [%sexp_of: (float, _, _) Private.Bigarray_helpers.Array2.t] let examples = List.init 3 ~f:(fun imax -> List.init 3 ~f:(fun jmax -> Array.init jmax ~f:(fun j -> Array.init imax ~f:(fun i -> Float.of_int (((j + 1) * 10) + i + 1))) |> Bigarray.Array2.of_array kind Fortran_layout)) |> List.concat ;; end in test_shrinker t (module M); [%expect {| (shrinker (((()) => ()) ((() ()) => (())) ((() ()) => (())) (((11)) => ()) (((11)) => (())) (((11) (21)) => ((21))) (((11) (21)) => (() ())) (((11) (21)) => ((11))) (((11 12)) => ()) (((11 12)) => ((12))) (((11 12)) => ((11))) (((11 12) (21 22)) => ((21 22))) (((11 12) (21 22)) => ((12) (22))) (((11 12) (21 22)) => ((11 12))) (((11 12) (21 22)) => ((11) (21))))) |}] in test float32_mat Bigarray.Float32; [%expect {| |}]; test float64_mat Float64; [%expect {| |}] ;; base_quickcheck-0.17.1/test/src/test_shrinker.mli000066400000000000000000000000601501616613400220400ustar00rootroot00000000000000include module type of Base_quickcheck.Shrinker base_quickcheck-0.17.1/test/src/test_test.ml000066400000000000000000000112031501616613400210220ustar00rootroot00000000000000open! Import module type S = Test.S module Config = Test.Config let default_config = Test.default_config let%expect_test ("default_config" [@tags "64-bits-only"]) = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> print_s [%sexp (default_config : Config.t)]); [%expect {| ((seed (Deterministic "an arbitrary but deterministic string")) (test_count 10000) (shrink_count 10000) (sizes (0 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 0 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 0 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 0 1 2 3 4 5 6 ...))) |}] ;; let%expect_test ("default_config" [@tags "32-bits-only"]) = Ref.set_temporarily sexp_style To_string_hum ~f:(fun () -> print_s [%sexp (default_config : Config.t)]); [%expect {| ((seed (Deterministic "an arbitrary but deterministic string")) (test_count 1000) (shrink_count 10000) (sizes (0 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 0 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 0 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 0 1 2 3 4 5 6 ...))) |}] ;; let run = Test.run let result = Test.result let run_exn = Test.run_exn let%expect_test "run_exn" = let module M = struct type t = bool option list [@@deriving sexp_of] let quickcheck_generator = Generator.list (Generator.option Generator.bool) let quickcheck_shrinker = Shrinker.list (Shrinker.option Shrinker.bool) end in let module M_without_shrinker = struct include M let quickcheck_shrinker = Shrinker.atomic end in (* success *) let count = ref 0 in require_does_not_raise [%here] (fun () -> Test.run_exn (module M) ~f:(fun _ -> Int.incr count)); require [%here] (!count = Test.default_config.test_count) ~if_false_then_print_s:(lazy [%message (!count : int)]); [%expect {| |}]; (* failure *) let failure list = assert (List.is_sorted list ~compare:[%compare: bool option]) in (* large sizes to demonstrate shrinking *) let config = { Test.default_config with sizes = Sequence.cycle_list_exn [ 10; 20; 30 ] } in (* simple failure *) require_does_raise [%here] ~hide_positions:true (fun () -> Test.run_exn ~config ~f:failure (module M)); [%expect {| ("Base_quickcheck.Test.run: test failed" (input ((false) ())) (error "Assert_failure test_test.ml:LINE:COL")) |}]; (* failure without shrinking *) require_does_raise [%here] ~hide_positions:true (fun () -> Test.run_exn ~config ~f:failure (module M_without_shrinker)); [%expect {| ("Base_quickcheck.Test.run: test failed" (input (() () (false) (true) (false) ())) (error "Assert_failure test_test.ml:LINE:COL")) |}]; (* failure from examples *) require_does_raise [%here] ~hide_positions:true (fun () -> Test.run_exn ~config ~f:failure ~examples:[ [ Some true; Some true; None; Some true; Some true ] ] (module M)); [%expect {| ("Base_quickcheck.Test.run: test failed" (input ((true) ())) (error "Assert_failure test_test.ml:LINE:COL")) |}]; (* failure from examples without shrinking *) require_does_raise [%here] ~hide_positions:true (fun () -> Test.run_exn ~config ~f:failure (module M_without_shrinker) ~examples:[ [ Some true; Some true; None; Some true; Some true ] ]); [%expect {| ("Base_quickcheck.Test.run: test failed" (input ((true) (true) () (true) (true))) (error "Assert_failure test_test.ml:LINE:COL")) |}] ;; let with_sample = Test.with_sample let with_sample_exn = Test.with_sample_exn let%expect_test "with_sample_exn" = let generator = Generator.list (Generator.option Generator.bool) in with_sample_exn generator ~config:{ Test.default_config with test_count = 20 } ~f:(fun sample -> Sequence.iter sample ~f:(fun value -> Core.print_s [%sexp (value : bool option list)])); [%expect {| () () (() (true)) (() (true) (false)) () ((true)) ((true)) ((true)) () (() (false) (true)) (() () (false) (true) () (true) () ()) ((true) () () () (true) (false) ()) (() () (true) () () (false) (false)) (() () (true) (true) (false) () (true) ()) () () ((true) (true) () (false) (false) () () () () (true) () () (true) (false) (false) ()) ((true) (false) (true)) ((false) () () (false) () () () (false) (false) () (true) () () () () (false)) () |}] ;; base_quickcheck-0.17.1/test/src/test_test.mli000066400000000000000000000000541501616613400211750ustar00rootroot00000000000000include module type of Base_quickcheck.Test