├── .github ├── dependabot.yml └── workflows │ ├── check-asciidoc.yml │ ├── gh-pages.yml │ └── main.yml ├── .gitignore ├── .gitmodules ├── .header ├── .travis.yml ├── AUTHORS ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.adoc ├── doc ├── qcheck-core │ ├── dune │ └── index.mld └── qcheck │ ├── dune │ └── index.mld ├── dune-project ├── example ├── QCheck_runner_test.expected.ocaml4.32 ├── QCheck_runner_test.expected.ocaml4.64 ├── QCheck_runner_test.expected.ocaml5.32 ├── QCheck_runner_test.expected.ocaml5.64 ├── QCheck_runner_test.ml ├── alcotest │ ├── QCheck_alcotest_test.expected.ocaml4.32 │ ├── QCheck_alcotest_test.expected.ocaml4.64 │ ├── QCheck_alcotest_test.expected.ocaml5.32 │ ├── QCheck_alcotest_test.expected.ocaml5.64 │ ├── QCheck_alcotest_test.ml │ ├── dune │ └── run_alcotest.sh ├── dune └── ounit │ ├── QCheck_ounit_test.expected.ocaml4.32 │ ├── QCheck_ounit_test.expected.ocaml4.64 │ ├── QCheck_ounit_test.expected.ocaml5.32 │ ├── QCheck_ounit_test.expected.ocaml5.64 │ ├── QCheck_ounit_test.ml │ ├── QCheck_test.ml │ ├── dune │ └── run_ounit.sh ├── ppx_deriving_qcheck.opam ├── qcheck-alcotest.opam ├── qcheck-core.opam ├── qcheck-ounit.opam ├── qcheck.opam ├── src ├── QCheck_runner.ml ├── alcotest │ ├── QCheck_alcotest.ml │ ├── QCheck_alcotest.mli │ └── dune ├── core │ ├── QCheck.ml │ ├── QCheck.mli │ ├── QCheck2.ml │ ├── QCheck2.mli │ └── dune ├── dune ├── ounit │ ├── QCheck_ounit.ml │ ├── QCheck_ounit.mli │ └── dune ├── ppx_deriving_qcheck │ ├── QCheck_generators.ml │ ├── README.md │ ├── args.ml │ ├── attributes.ml │ ├── attributes.mli │ ├── dune │ ├── ppx_deriving_qcheck.ml │ ├── ppx_deriving_qcheck.mli │ └── tuple.ml └── runner │ ├── QCheck_base_runner.ml │ ├── QCheck_base_runner.mli │ └── dune └── test ├── core ├── QCheck2_expect_test.expected.ocaml4.32 ├── QCheck2_expect_test.expected.ocaml4.64 ├── QCheck2_expect_test.expected.ocaml5.32 ├── QCheck2_expect_test.expected.ocaml5.64 ├── QCheck2_expect_test.ml ├── QCheck2_tests.ml ├── QCheck2_unit_tests.ml ├── QCheck_expect_test.expected.ocaml4.32 ├── QCheck_expect_test.expected.ocaml4.64 ├── QCheck_expect_test.expected.ocaml5.32 ├── QCheck_expect_test.expected.ocaml5.64 ├── QCheck_expect_test.ml ├── QCheck_tests.ml ├── QCheck_unit_tests.ml ├── dune ├── rng_independence.ml └── shrink_benchmark.ml └── ppx_deriving_qcheck └── deriver ├── qcheck ├── dune ├── helpers.ml ├── test_primitives.ml ├── test_qualified_names.ml ├── test_record.ml ├── test_recursive.ml ├── test_textual.ml ├── test_tuple.ml └── test_variants.ml └── qcheck2 ├── dune ├── helpers.ml ├── test_mutual.ml ├── test_primitives.ml ├── test_qualified_names.ml ├── test_record.ml ├── test_recursive.ml ├── test_textual.ml ├── test_tuple.ml └── test_variants.ml /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "weekly" 7 | -------------------------------------------------------------------------------- /.github/workflows/check-asciidoc.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | branches: 8 | - main 9 | jobs: 10 | run: 11 | name: Check asciidoc 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v4 15 | - run: | 16 | sudo apt-get update -y 17 | sudo apt-get install -y asciidoc-base 18 | - run: asciidoc README.adoc 19 | -------------------------------------------------------------------------------- /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master # Set a branch name to trigger deployment 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@main 13 | 14 | - name: Cache opam 15 | id: cache-opam 16 | uses: actions/cache@v4 17 | with: 18 | path: ~/.opam 19 | key: opam-ubuntu-latest-4.12.0 20 | 21 | - uses: avsm/setup-ocaml@v3 22 | with: 23 | ocaml-version: '4.12.0' 24 | 25 | - name: Pin 26 | run: opam pin -n . 27 | 28 | - name: Depext 29 | run: opam depext -yt qcheck-ounit qcheck-core qcheck 30 | 31 | - name: Deps 32 | run: opam install -d . --deps-only 33 | 34 | - name: Build 35 | run: opam exec -- dune build @doc 36 | 37 | - name: Deploy 38 | uses: peaceiris/actions-gh-pages@v4 39 | with: 40 | github_token: ${{ secrets.GITHUB_TOKEN }} 41 | publish_dir: ./_build/default/_doc/_html/ 42 | destination_dir: dev 43 | enable_jekyll: true 44 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | branches: 8 | - main 9 | jobs: 10 | run: 11 | name: Build 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - macos-latest 17 | - ubuntu-latest 18 | - windows-latest 19 | ocaml-compiler: 20 | - "4.08" 21 | - "4.12" 22 | - "4.14" 23 | - "5.0" 24 | - "5.1" 25 | - "5.2" 26 | - "5.3" 27 | exclude: 28 | - os: macos-latest 29 | ocaml-compiler: "4.08" 30 | - os: windows-latest 31 | ocaml-compiler: "4.08" 32 | - os: windows-latest 33 | ocaml-compiler: "4.12" 34 | runs-on: ${{ matrix.os }} 35 | steps: 36 | - uses: actions/checkout@v4 37 | - uses: ocaml/setup-ocaml@v3 38 | with: 39 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 40 | - run: opam update -y 41 | - run: opam install . --deps-only --with-test 42 | - run: opam exec -- dune build 43 | - run: opam exec -- dune runtest 44 | 45 | i386: 46 | strategy: 47 | fail-fast: false 48 | matrix: 49 | container-image: 50 | - ocaml/opam:debian-12-ocaml-4.14 51 | - ocaml/opam:debian-12-ocaml-5.3 52 | runs-on: ubuntu-latest 53 | container: 54 | image: ${{ matrix.container-image }} 55 | options: --platform linux/i386 56 | steps: 57 | # GitHub insists on HOME=/github/home which clashes with the opam image setup 58 | - name: Setup, init, and update opam 59 | run: | 60 | sudo cp /usr/bin/opam-2.3 /usr/bin/opam 61 | cd /home/opam && HOME=/home/opam opam init -y 62 | git -C /home/opam/opam-repository pull origin master && HOME=/home/opam opam update -y 63 | - name: Checkout repository 64 | # See https://github.com/actions/checkout/issues/334 65 | uses: actions/checkout@v1 66 | - name: Setup repo and install dependencies 67 | run: | 68 | sudo chown -R opam:opam . 69 | HOME=/home/opam opam install . --deps-only --with-test 70 | - name: Build 71 | run: HOME=/home/opam opam exec -- dune build 72 | - name: Run the testsuite 73 | run: HOME=/home/opam opam exec -- dune runtest 74 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .*.swo 3 | _build 4 | *.native 5 | .session 6 | TAGS 7 | *.docdir 8 | man 9 | *.install 10 | *.tar.gz 11 | *.byte 12 | .merlin 13 | _opam/ 14 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "check-fun"] 2 | path = check-fun 3 | url = https://github.com/jmid/qcheck-fun 4 | -------------------------------------------------------------------------------- /.header: -------------------------------------------------------------------------------- 1 | (* 2 | QCheck: Random testing for OCaml 3 | copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard 4 | all rights reserved. 5 | *) 6 | 7 | 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="qcheck:. qcheck-core:. qcheck-ounit:. qcheck-alcotest:." 9 | - DISTRO="ubuntu-16.04" 10 | - PACKAGE="qcheck" 11 | - DEPOPTS="ounit alcotest" 12 | matrix: 13 | # OCAML_VERSION is used by https://github.com/ocaml/ocaml-ci-scripts/blob/master/README-travis.md 14 | - OCAML_VERSION="4.08" 15 | - OCAML_VERSION="4.09" 16 | - OCAML_VERSION="4.10" 17 | - OCAML_VERSION="4.11" 18 | - OCAML_VERSION="4.12" 19 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Simon Cruanes 2 | Rudi Grinberg 3 | Jacques-Pascal Deplaix 4 | Jan Midtgaard 5 | Valentin Chaboche 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changes 2 | 3 | ## NEXT RELEASE 4 | 5 | - Fix QCheck2 `float_range` operator which would fail on negative bounds 6 | - Fix `QCHECK_MSG_INTERVAL` not being applied to the first in-progress message 7 | 8 | ## 0.25 9 | 10 | - Restore `Test.make`'s `max_fail` parameter which was accidentally broken in 0.18 11 | - Adjust `stats` computation of average and standard deviation to 12 | limit precision loss, print both using scientific notation, and 13 | workaround MinGW float printing to also pass expect tests 14 | - Fix dune snippets missing a language specifier in README.adoc 15 | causing `asciidoc` to error 16 | - Add a note to `QCheck{,2.Gen}.small_int_corners` and `QCheck{,2}.Gen.graft_corners` 17 | about internal state, and fix a range of documentation reference warnings 18 | - Reorganize and polish the `README`, rewrite it to use `qcheck-core`, and add 19 | a `QCheck2` integrated shrinking example 20 | - Document `QCHECK_MSG_INTERVAL` introduced in 0.20 21 | - Add `QCheck{,2}.Gen.map{4,5}` combinators 22 | - [ppx_deriving_qcheck] Support `ppxlib.0.36.0` based on the OCaml 5.2 AST 23 | 24 | ## 0.24 25 | 26 | - [qcheck-alcotest] Add an optional `speed_level` parameter to `to_alcotest` 27 | - Adjust the `QCheck2.Gen.list` shrinker to produce minimal counterexamples at size 3 too 28 | - Replace the `QCheck2` OCaml 4 `Random.State.split` hack with a faster one 29 | - Improve the `QCheck2.Gen.list` shrinker heuristic and utilize the improved 30 | shrinker in other `QCheck2` `{list,array,bytes,string,function}*` shrinkers 31 | - Use `split` and `copy` in `Random.State` underlying `QCheck2` to 32 | avoid non-deterministic shrinking behaviour 33 | - Add missing documentation strings for `QCheck.{Print,Iter,Shrink,Gen}` and `QCheck2.Gen`. 34 | - Add `result` combinators to `QCheck`, `QCheck.{Gen,Print,Shrink,Observable}`, 35 | and `QCheck2.{Gen,Print,Observable}`. 36 | - Add missing combinators `QCheck{,2}.Print.int{32,64}`, `QCheck.Gen.int{32,64}`, 37 | `QCheck{,2}.Observable.int{32,64}`, and deprecate `QCheck.Gen.{ui32,ui64}` 38 | - Document `dune` usage in README 39 | 40 | ## 0.23 41 | 42 | - Quote and escape in `Print.string` and `Print.char` in the `QCheck` module, 43 | mirroring the `QCheck2.Print` module's behaviour. Also quote and 44 | escape `Print.bytes` in both `QCheck` and `QCheck2`. 45 | - Clean-up `QCheck` and `QCheck2` documentation pages 46 | - Add `exponential` generator to `QCheck`, `QCheck.Gen`, and `QCheck2.Gen` 47 | - Add `Shrink.bool` and use it in `QCheck.bool` 48 | - Remove unread `fun_gen` field from `QCheck2`'s `fun_repr_tbl` type 49 | thereby silencing a compiler warning 50 | 51 | ## 0.22 52 | 53 | - Remove `QCheck2.TestResult.get_instances` as retaining previous test inputs 54 | cause memory leaks 55 | - Make `QCheck2.state.res` immutable, silencing a compilation warning 56 | 57 | ## 0.21.3 58 | 59 | - Drop the dependency on `base-bytes` as it is provided in all supported 60 | versions of the OCaml compiler 61 | 62 | ## 0.21.2 63 | 64 | - Reintroduce the `Shrink.list_spine` fix by catching `Invalid_argument` and 65 | falling back on an address comparison. 66 | - Fix #273 by lowering `ppx_deriving_qcheck`'s `qcheck` dependency to `qcheck-core` 67 | 68 | ## 0.21.1 69 | 70 | - Roll back the `Shrink.list_spine` fix, as it was utilizing polymorphic 71 | equality that can raise an exception on function comparison. 72 | 73 | ## 0.21 74 | 75 | - make `Test.check_result`, `Test.check_cell_exn`, and 76 | `Test.check_exn` honor test polarity by raising 77 | `Test_unexpected_success` when a negative test (expected to have a 78 | counter example), unexpectedly succeeds. 79 | - fix issue with `ppx_deriving_qcheck` deriving a generator with unbound 80 | `gen` for recursive types [#269](https://github.com/c-cube/qcheck/issues/269) 81 | and a related issue when deriving a generator for a record type 82 | - fix #241 causing `QCheck.Shrink.int*` to emit duplicates, also affecting `QCheck.Shrink.{char,string}` 83 | - fix a cornercase where `Shrink.list_spine` would emit duplicates 84 | 85 | ## 0.20 86 | 87 | - add several new `bytes` combinators: 88 | - `{QCheck,QCheck2}.Gen.{bytes_size,bytes,bytes_of,bytes_printable,bytes_small,bytes_small_of}` 89 | - `QCheck.{Print,Shrink,Observable}.bytes` 90 | - `QCheck2.{Print,Shrink}.bytes` 91 | - `QCheck.{bytes_gen_of_size,bytes_of,bytes,bytes_small,bytes_small_of,bytes_of_size,bytes_printable}` 92 | - add new `string` combinators and aliases: 93 | - `{QCheck,QCheck2}.Gen.{string_small,string_small_of}` 94 | - `QCheck.{string_small,string_small_of,string_of,string_printable,string_printable_of_size,string_small_printable,string_numeral,string_numeral_of_size}` 95 | - (`QCheck2.small_string` character generator argument is no more optional - reverted again due to backwards incompatibility) 96 | - add an optional argument with conservative default to `Shrink.string` 97 | - fix shrinkers in `QCheck.{printable_string,printable_string_of_size,small_printable_string,numeral_string,numeral_string_of_size}` [#257](https://github.com/c-cube/qcheck/issues/257) 98 | - add `QCheck2.Gen.set_shrink` to modify the generator's shrinker 99 | - add `QCheck2.Gen.no_shrink` to build a generator with no shrinking 100 | - add an environment variable `QCHECK_MSG_INTERVAL` to control `QCheck_base_runner.time_between_msg` 101 | - fix unknown option error message referring to `qtest` 102 | 103 | ## 0.19.1 104 | 105 | - fix: allow `~count` in `Test.make` to be 0 106 | - fix: allow `~long_factor` in `Test.make` to be 0 107 | 108 | ## 0.19 109 | 110 | - use `Float.equal` for comparing `float`s in the `Observable` module underlying function generators. 111 | 112 | - add optional `debug_shrink` parameters in alcotest interface and 113 | expose default `debug_shrinking_choices` in test runners 114 | 115 | - add missing `?handler` parameter to `Test.check_cell_exn` 116 | 117 | - remove `--no-buffer` option on `dune runtest` to avoid garbling the 118 | test output 119 | 120 | - add an option `retries` parameter to `Test.make` et al. for checking a 121 | property repeatedly while shrinking. 122 | This can be useful when testing non-deterministic code. 123 | [#212](https://github.com/c-cube/qcheck/pull/212) 124 | 125 | - add `tup2` to `tup9` for generators 126 | 127 | - add `Test.make_neg` for negative property-based tests, that are 128 | expected not to satisfy the tested property. 129 | 130 | - rename `Gen.opt` to `Gen.option` but keep the old binding for compatibility. 131 | 132 | - add additional expect and unit tests and refactor expect test suite 133 | 134 | - fix function generation affecting reproducability [#236](https://github.com/c-cube/qcheck/issues/236) 135 | 136 | - add a shrinker performance benchmark [#177](https://github.com/c-cube/qcheck/pull/177) 137 | 138 | - fix distribution of `QCheck2.printable` which would omit certain characters 139 | 140 | - shrinker changes 141 | - recursive list shrinker with better complexity 142 | - string shrinker reuses improved list shrinker and adds char shrinking 143 | - function shrinker now shrinks default entry first and benefits from list shrinker improvements 144 | - replacing the linear-time char shrinker with a faster one reusing the bisecting int shrinker algorithm 145 | - add `Shrink.char_numeral` and `Shrink.char_printable` 146 | - add shrinking for `char arbitrary`s `char`, `printable_char`, and `numeral_char` 147 | 148 | - documentation updates: 149 | - clarify upper bound inclusion in `Gen.int_bound` and `Gen.int_range` 150 | - clarify `printable_char` and `Gen.printable` distributions 151 | - add missing `string_gen_of_size` and `small_printable_string` documentation 152 | - document `QCheck_alcotest.to_alcotest` 153 | - fix documented size distribution for `arbitrary` generators 154 | `string_gen`, `string`, `printable_string`, `numeral_string`, `list`, and `array` 155 | - fix exception documentation for `check_result`, `check_cell_exn`, and `check_exn` 156 | - fix documentation for the distribution of `Gen.printable` and `printable_char` 157 | - fix documentation for the shrinking behaviour of `QCheck2.printable` 158 | 159 | - add environment variable `QCHECK_LONG_FACTOR` similar to `QCHECK_COUNT` [#220](https://github.com/c-cube/qcheck/pull/220) 160 | 161 | - make test suite run on 32-bit architectures 162 | 163 | ## 0.18.1 164 | 165 | - fix `Gen.{nat,pos}_split{2,}` 166 | - fix stack overflow in #156 167 | 168 | ## 0.18 169 | 170 | This releases marks the addition of `QCheck2`, a module where generation 171 | and shrinking are better integrated. 172 | See [#109](https://github.com/c-cube/qcheck/pull/109) and [#116](https://github.com/c-cube/qcheck/pull/116). 173 | 174 | This API is still experimental. The normal `QCheck` module is still there 175 | and hasn't changed much. 176 | 177 | deprecations and breakges: 178 | 179 | - make `QCheck.Test_result.t` abstract and add missing getters 180 | - deprecate `QCheck.oneof` 181 | - deprecate `Gen.string_readable` in favor of `Gen.(string_of char)` or the new `Gen.string_printable` 182 | - require at least OCaml 4.08 183 | 184 | other changes: 185 | 186 | - unsigned int32 and int64 187 | - rename `small_int_corners` 188 | - add `?ratio` to `opt`, to modify random distribution of options 189 | 190 | ## 0.17 191 | 192 | - new function: `Gen.delay` 193 | 194 | - install printer for an internal exception 195 | - fix(runner): use random state independently for each test 196 | - Fixes distribution and `min_int` issues 197 | - doc: point to @jmid 's website 198 | 199 | ## 0.16 200 | 201 | - fix(runner): detect more failures in the runner 202 | - fix: catch exceptions in generators and log them. (#99) 203 | - test: add test for #99 204 | - fix doc 205 | 206 | ## 0.15 207 | 208 | - fix: in main runner, remove reset line in more places if `colors=false` 209 | - fix: invalid arg in `int_range` when a<0 210 | - fix(runner): do not use ansi code for random seed if `colors=false` 211 | - feat: on `>=4.08`, provide let operators 212 | 213 | ## 0.14 214 | 215 | - modify `int_range` to make it accept ranges bigger than `max_int`. 216 | - less newline-verbose stats 217 | - add `int{32,64}` shrinkers to arbitrary gens 218 | - add `int{32,int64}` shrinkers 219 | - move to ounit2 for `QCheck_ounit` 220 | 221 | ## 0.13 222 | 223 | - make counter private 224 | - Add debug shrinking log 225 | - fix: small fix related to stdlib/pervasives 226 | - feat: add flatten combinators in `gen` 227 | 228 | ## 0.12 229 | 230 | - fix singleton list shrinking 231 | - feat: add `Gen.char_range` and `Gen.(<$>)` (credit @spewspews) 232 | 233 | ## 0.11 234 | 235 | - Add `QCheck.Gen.{string_of,string_readable}` 236 | - fix `int_bound` bound inclusiveness problem 237 | - change implementation of `int_bound` to generate values using `Random.State.int` for `bound < 2^30` 238 | - add weighted shuffled lists generator 239 | - add `float_range` to generate a floating-point number in the given range (inclusive) 240 | - add `float_bound_inclusive` and `float_bound_exclusive` to generate floating-point numbers between 0 and a given bound 241 | 242 | ## 0.10 243 | 244 | - `Shrink`: decompose Shrink.list into Shrink.list_spine and Shrink.list_elems 245 | - `Gen.fix` has a more general and useful type 246 | - update README to include `Rely` section (qcheck now available for reason-native!) 247 | - Fix stat printing 248 | - speed-up list shrinker 249 | - Better int shrinking 250 | - core: modify proba distributions again, add `big_nat` 251 | - feat: add `small_array`, modify distributions 252 | - print number of warnings in runner's summary 253 | - refactor: modify type of results to make them more accurate 254 | - feat: warn/fail if too many tests passed only b/c precondition failed 255 | 256 | ## 0.9 257 | 258 | - add `qcheck-ounit` sublibrary 259 | - use environment variables to configure `qcheck-alcotest` tests 260 | - alcotest backend for qcheck 261 | - make `qcheck.ounit` tests verbose by default 262 | - make `qcheck` is a compatibility library, depends on `qcheck-core` 263 | - split lib into `qcheck` and `qcheck.ounit` 264 | - add `TestResult.is_success` helper 265 | - give access to list of instances in test results 266 | - allow setting `time_between_msg` in runner 267 | 268 | - chore: remove submodule 269 | - chore: add travis support 270 | - doc: explanations about qcheck.ounit runners 271 | - doc: update readme 272 | 273 | ## 0.8 274 | 275 | - migrate to jbuilder 276 | - fix warnings 277 | - add some useful functions 278 | - update oasis files (close #48) 279 | - update copyright header (closes #47) 280 | 281 | ## 0.7 282 | 283 | - switch to BSD license, make it more explicit (close #43) 284 | - improve multi-line message printing in ounit (closes #46) 285 | - fix complexity of `add_stat` 286 | - allow negative entries in statistics (see #40) 287 | - add a way for tests to report messages to the user (see #39) 288 | - add `QCheck.Shrink.int_aggressive` and make default int shrinker faster 289 | - shrinker for `map_keep_input` 290 | - add `QCheck.set_gen`, missing for some reason 291 | 292 | - more compact verbose output (see #33) 293 | - better handling of dynamic progress line 294 | - Add colors to checkmarks in verbose mode 295 | - improve statistics display for runner 296 | 297 | - recover exception of shrunk input 298 | - print status line before the solving starts 299 | 300 | ## 0.6 301 | 302 | - add `find_example` and `find_example_gen` to synthesize values from 303 | properties (see #31) 304 | - add `QCheck.gen` for accessing the random generator easily 305 | - colorful runners, with `--no-colors` to disable them 306 | - add more generator (for corner cases) 307 | - better generation of random functions (see #8), 308 | using `Observable` and an efficient internal representation using 309 | heterogeneous tuples, printing, and shrinking. deprecate old hacks. 310 | - add statistics gathering and display (see #30) 311 | 312 | - better printing of Tuple 313 | - improve `Shrink.{array,list}` (see #32) 314 | - Change asserts to raise `Invalid_arg` (following the doc), and update doc 315 | - Change `Gen.{int_bount,int_range}` to support up to 2^62 316 | 317 | ## 0.5.3.1 318 | 319 | - fix regression in runner output (print results of `collect`) 320 | - update the `@since` tags 321 | 322 | ## 0.5.3 323 | 324 | - missing char in `Gen.char` (close #23) 325 | - add `test` and `doc` to opam 326 | - add `small_list` generator 327 | - add `~long_factor` to tests and runner, for long tests 328 | - add more examples in readme, better doc for runners 329 | - improved reporting when running qcheck tests 330 | - add `Test.get_count` on test cells 331 | 332 | ## 0.5.2 333 | 334 | - Add cli option for backtraces in `QCheck_runner` 335 | - Add test case for raising exception 336 | - Better handling of backtraces 337 | - All tests now have a name 338 | - Add step function called on each instance in a test 339 | - make `small_int` a deprecated alias to `small_nat` 340 | - add `small_signed_int` 341 | - remove some warnings 342 | - use safe-string, and fix related bug 343 | - Add long tests options to `QCheck_runner` 344 | - Add `length` specification for `to_ounit2_test` 345 | - Added paragraph in README about long tests 346 | 347 | ## 0.5.1 348 | 349 | - document exceptions 350 | - add `small_nat`, change `small_int` semantics (close #10) 351 | - add `QCheck.assume_fail` 352 | - add `QCheck.assume`; explain preconditions a bit (close #9) 353 | - Polish documentation 354 | - Added quad support uniformly 355 | 356 | ## 0.5 357 | 358 | - merge back from `qtest`: big changes in API, shrinking, use `'a arbitrary` 359 | type that combines printer, generator, shrinker, etc. (see git log) 360 | - merlin file 361 | - reorganize sources, `_oasis`, `.merlin`, etc. 362 | 363 | ## 0.4 364 | 365 | - bugfix in `fix_fuel` 366 | 367 | - if verbose enabled, print each test case 368 | - add `QCheck.run_main` 369 | - `QCheck_ounit.~::` 370 | - add `(>:::)` 371 | - add `qcheck_ounit ml{lib,dylib}` 372 | - trivial ounit integration 373 | - make `test_cell.name` optional 374 | - `Arbitrary.fix_fuel(_gen)`: add a recursive case 375 | - `Arbitrary.fix_fuel_gen`, similar to `fix_fuel` but threading a state bottom-up to make choices depend on the path 376 | - `Arbitrary.fail_fix` to fail in a fixpoint 377 | - helper cases for `Arbitrary.fix_fuel` 378 | 379 | ## 0.3 380 | 381 | - get rid of submodule `generator` 382 | - `Arbitrary.fix_fuel`, to generate complex recursive structures 383 | - new combinators (infix map, applicative funs, shuffle) 384 | - remove generator/Generator, and a deprecation warning 385 | - output of printers of lists/arrays now parsable by ocaml toplevel 386 | 387 | ## 0.2 388 | 389 | - integrate Gabriel Scherer's `Generator` into `QCheck` 390 | - add `|||` 391 | - add `Prop.raises` 392 | - print the faulty instance in case of error (if a printer is available) 393 | - some combinators for `QCheck.Arbitrary` 394 | - `QCheck.mk_test` takes more arguments 395 | 396 | ## 0.1 397 | 398 | - oasis based build system 399 | - source files 400 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. Redistributions in binary 9 | form must reproduce the above copyright notice, this list of conditions and 10 | the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 20 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 21 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 22 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: build test 3 | 4 | build: 5 | @dune build @install 6 | 7 | test: 8 | @dune runtest --force 9 | 10 | clean: 11 | @dune clean 12 | 13 | doc: 14 | @dune build @doc 15 | 16 | example-test: 17 | @dune exec example/ounit/QCheck_test.exe 18 | 19 | example-ounit-test: 20 | @dune exec example/ounit/QCheck_ounit_test.exe 21 | 22 | example-runner: 23 | @dune exec example/QCheck_runner_test.exe -- -v --debug-shrink=log.tmp 24 | 25 | example-alcotest: 26 | @dune exec example/alcotest/QCheck_alcotest_test.exe 27 | 28 | VERSION=$(shell awk '/^version:/ {print $$2}' qcheck.opam) 29 | 30 | update_next_tag: 31 | @echo "update version to $(VERSION)..." 32 | sed -i "s/NEXT_VERSION/$(VERSION)/g" `find src -name '*.ml' -or -name '*.mli'` 33 | sed -i "s/NEXT_RELEASE/$(VERSION)/g" `find src -name '*.ml' -or -name '*.mli'` 34 | 35 | release: update_next_tag 36 | @echo "release version $(VERSION)..." 37 | git tag -f $(VERSION) ; git push origin :$(VERSION) ; git push origin $(VERSION) 38 | opam publish https://github.com/c-cube/qcheck/archive/$(VERSION).tar.gz 39 | @echo "review the release, then type 'opam publish submit qcheck.$(VERSION)/'" 40 | 41 | 42 | watch: 43 | @dune build @all -w 44 | 45 | .PHONY: benchs test examples update_next_tag watch release 46 | -------------------------------------------------------------------------------- /README.adoc: -------------------------------------------------------------------------------- 1 | = QCheck 2 | :toc: macro 3 | :toclevels: 4 4 | :source-highlighter: pygments 5 | 6 | QuickCheck inspired property-based testing for OCaml. 7 | 8 | image::https://github.com/c-cube/qcheck/actions/workflows/main.yml/badge.svg[alt="build", link=https://github.com/c-cube/qcheck/actions/workflows/main.yml] 9 | 10 | == Overview 11 | 12 | `QCheck` consists of a collection of `opam` packages and extensions: 13 | 14 | - `qcheck-core` - provides the core property-based testing API and depends only 15 | on `unix` and `dune`. 16 | - `qcheck-ounit` - provides an integration layer for https://github.com/gildor478/ounit[`OUnit`] 17 | - `qcheck-alcotest` - provides an integration layer for https://github.com/mirage/alcotest[`alcotest`] 18 | - `qcheck` - provides a compatibility API with older versions of `qcheck`, 19 | using both `qcheck-core` and `qcheck-ounit`. 20 | - `ppx_deriving_qcheck` - provides a preprocessor to automatically derive 21 | generators 22 | 23 | In addition, the https://github.com/ocaml-multicore/multicoretests[`multicoretests`] 24 | repository offers 25 | 26 | - `qcheck-stm` - for running sequential and parallel model-based tests 27 | - `qcheck-lin` - for testing an API for sequential consistency 28 | - `qcheck-multicoretests-util` - a small library of utility extensions, such as 29 | properties with time outs 30 | 31 | To construct advanced random generators, the following libraries might also be 32 | of interest: 33 | 34 | - https://gitlab.inria.fr/fpottier/feat/[`feat`] - a library for functional 35 | enumeration and sampling of algebraic data types 36 | - https://github.com/gasche/random-generator/[`random-generator`] - a library 37 | experimenting with APIs for random generation 38 | 39 | Earlier `qcheck` spent some time in https://github.com/vincent-hugot/iTeML[qtest], 40 | but was since made standalone again. 41 | 42 | 43 | == Documentation 44 | 45 | The documentation for the 5 opam packages https://c-cube.github.io/qcheck/[is available here]. 46 | 47 | The section <> below offer a brief introduction to the 48 | library. These examples are based on an earlier 49 | https://cedeela.fr/quickcheck-for-ocaml[blog post by Simon] that also 50 | discusses some design choices; however, be warned that the API changed 51 | since then, so the blog post code will not work as is. 52 | 53 | Jan's http://janmidtgaard.dk/quickcheck/index.html[course material on 54 | FP and property-based testing] also offers an introduction to QCheck. 55 | 56 | The OCaml textbook from Cornell University also contains 57 | https://cs3110.github.io/textbook/chapters/correctness/randomized.html[a 58 | chapter about property-based testing with QCheck]. 59 | 60 | 61 | == Build and Install 62 | 63 | You can install QCheck via `opam`: 64 | 65 | $ opam install qcheck-core 66 | 67 | This provides a minimal installation without needless dependencies. 68 | 69 | Install the bigger `qcheck` package instead for compatibility with qcheck.0.8 70 | and before: 71 | 72 | $ opam install qcheck 73 | 74 | To build the library from source 75 | 76 | $ make 77 | 78 | Normally, for contributors, `opam pin https://github.com/c-cube/qcheck` 79 | will pin the 5 opam packages from this repository. 80 | 81 | 82 | == License 83 | 84 | The code is now released under the BSD license. 85 | 86 | [[examples]] 87 | == An Introduction to the Library 88 | 89 | First, let's see a few tests. Let's open a toplevel (e.g. utop) 90 | and type the following to load QCheck: 91 | 92 | [source,OCaml] 93 | ---- 94 | #require "qcheck-core";; 95 | ---- 96 | 97 | NOTE: alternatively, it is now possible to locally do: `dune utop src` 98 | to load `qcheck`. 99 | 100 | === List Reverse is Involutive 101 | 102 | We write a random test for checking that `List.rev (List.rev l) = l` for 103 | any list `l`: 104 | 105 | [source,OCaml] 106 | ---- 107 | let test = 108 | QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" 109 | QCheck.(list small_nat) 110 | (fun l -> List.rev (List.rev l) = l);; 111 | 112 | (* we can check right now the property... *) 113 | QCheck.Test.check_exn test;; 114 | ---- 115 | 116 | 117 | In the above example, we applied the combinator `list` to 118 | the random generator `small_nat` (ints between 0 and 100), to create a 119 | new generator of lists of random integers. These builtin generators 120 | come with printers and shrinkers which are handy for outputting and 121 | minimizing a counterexample when a test fails. 122 | 123 | Consider the buggy property `List.rev l = l`: 124 | 125 | [source,OCaml] 126 | ---- 127 | let test = 128 | QCheck.Test.make ~count:1000 ~name:"my_buggy_test" 129 | QCheck.(list small_nat) 130 | (fun l -> List.rev l = l);; 131 | ---- 132 | 133 | When we run this test we are presented with a counterexample: 134 | 135 | [source,OCaml] 136 | ---- 137 | # QCheck.Test.check_exn test;; 138 | Exception: 139 | test `my_buggy_test` failed on ≥ 1 cases: [0; 1] (after 11 shrink steps) 140 | ---- 141 | 142 | In this case QCheck found the minimal counterexample `[0;1]` to the property 143 | `List.rev l = l` and it spent 11 steps shrinking it. 144 | 145 | 146 | Now, let's run the buggy test with a decent runner that will print the results 147 | nicely (the exact output will change at each run, because of the random seed): 148 | 149 | ---- 150 | # #require "qcheck-core.runner";; 151 | # QCheck_base_runner.run_tests [test];; 152 | random seed: 452768242 153 | 154 | --- Failure -------------------------------------------------------------------- 155 | 156 | Test my_buggy_test failed (14 shrink steps): 157 | 158 | [0; 1] 159 | ================================================================================ 160 | failure (1 tests failed, 0 tests errored, ran 1 tests) 161 | - : int = 1 162 | ---- 163 | 164 | For an even nicer output `QCheck_base_runner.run_tests` also accepts an optional 165 | parameter `~verbose:true`. 166 | 167 | 168 | === Mirrors and Trees 169 | 170 | `QCheck` provides many useful combinators to write generators, especially for 171 | recursive types, algebraic types, and tuples. 172 | 173 | Let's see how to generate random trees: 174 | 175 | [source,OCaml] 176 | ---- 177 | type tree = Leaf of int | Node of tree * tree 178 | 179 | let leaf x = Leaf x 180 | let node x y = Node (x,y) 181 | 182 | let tree_gen = QCheck.Gen.(sized @@ fix 183 | (fun self n -> match n with 184 | | 0 -> map leaf nat 185 | | n -> 186 | frequency 187 | [1, map leaf nat; 188 | 2, map2 node (self (n/2)) (self (n/2))] 189 | ));; 190 | 191 | (* generate a few trees, just to check what they look like: *) 192 | QCheck.Gen.generate ~n:20 tree_gen;; 193 | 194 | let arbitrary_tree = 195 | let open QCheck.Iter in 196 | let rec print_tree = function 197 | | Leaf i -> "Leaf " ^ (string_of_int i) 198 | | Node (a,b) -> "Node (" ^ (print_tree a) ^ "," ^ (print_tree b) ^ ")" 199 | in 200 | let rec shrink_tree = function 201 | | Leaf i -> QCheck.Shrink.int i >|= leaf 202 | | Node (a,b) -> 203 | of_list [a;b] 204 | <+> 205 | (shrink_tree a >|= fun a' -> node a' b) 206 | <+> 207 | (shrink_tree b >|= fun b' -> node a b') 208 | in 209 | QCheck.make tree_gen ~print:print_tree ~shrink:shrink_tree;; 210 | ---- 211 | 212 | Here we write a generator of random trees, `tree_gen`, using 213 | the `fix` combinator. `fix` is *sized* (it is a function from `int` to 214 | a random generator; in particular for size 0 it returns only leaves). 215 | The `sized` combinator first generates a random size, and then applies 216 | its argument to this size. 217 | 218 | Other combinators include monadic abstraction, lifting functions, 219 | generation of lists, arrays, and a choice function. 220 | 221 | Then, we define `arbitrary_tree`, a `tree QCheck.arbitrary` value, which 222 | contains everything needed for testing on trees: 223 | 224 | - a random generator (mandatory), weighted with `frequency` to 225 | increase the chance of generating deep trees 226 | - a printer (optional), very useful for printing counterexamples 227 | - a *shrinker* (optional), very useful for trying to reduce big 228 | counterexamples to small counterexamples that are usually 229 | more easy to understand. 230 | 231 | The above shrinker strategy is to 232 | 233 | - reduce the integer leaves, and 234 | - substitute an internal `Node` with either of its subtrees or 235 | by splicing in a recursively shrunk subtree. 236 | 237 | A range of combinators in `QCheck.Shrink` and `QCheck.Iter` are available 238 | for building shrinking functions. 239 | 240 | 241 | We can write a failing test using this generator to see the 242 | printer and shrinker in action: 243 | 244 | [source,OCaml] 245 | ---- 246 | let rec mirror_tree (t:tree) : tree = match t with 247 | | Leaf _ -> t 248 | | Node (a,b) -> node (mirror_tree b) (mirror_tree a);; 249 | 250 | let test_buggy = 251 | QCheck.Test.make ~name:"buggy_mirror" ~count:200 252 | arbitrary_tree (fun t -> t = mirror_tree t);; 253 | 254 | QCheck_base_runner.run_tests [test_buggy];; 255 | ---- 256 | 257 | This test fails with: 258 | 259 | [source,OCaml] 260 | ---- 261 | 262 | --- Failure -------------------------------------------------------------------- 263 | 264 | Test mirror_buggy failed (6 shrink steps): 265 | 266 | Node (Leaf 0,Leaf 1) 267 | ================================================================================ 268 | failure (1 tests failed, 0 tests errored, ran 1 tests) 269 | - : int = 1 270 | ---- 271 | 272 | 273 | With the (new found) understanding that mirroring a tree 274 | changes its structure, we can formulate another property 275 | that involves sequentializing its elements in a traversal: 276 | 277 | [source,OCaml] 278 | ---- 279 | let tree_infix (t:tree): int list = 280 | let rec aux acc t = match t with 281 | | Leaf i -> i :: acc 282 | | Node (a,b) -> 283 | aux (aux acc b) a 284 | in 285 | aux [] t;; 286 | 287 | let test_mirror = 288 | QCheck.Test.make ~name:"mirror_tree" ~count:200 289 | arbitrary_tree 290 | (fun t -> List.rev (tree_infix t) = tree_infix (mirror_tree t));; 291 | 292 | QCheck_base_runner.run_tests [test_mirror];; 293 | ---- 294 | 295 | 296 | === Integrated shrinking with `QCheck2` 297 | 298 | You may have noticed the `shrink_tree` function above to reduce tree 299 | counterexamples. With the newer `QCheck2` module, this is not needed 300 | as shrinking is built into its generators. 301 | 302 | For example, we can rewrite the above tree generator to `QCheck2` by just 303 | changing the `QCheck` occurrences to `QCheck2`: 304 | 305 | [source,OCaml] 306 | ---- 307 | type tree = Leaf of int | Node of tree * tree 308 | 309 | let leaf x = Leaf x 310 | let node x y = Node (x,y) 311 | 312 | let tree_gen = QCheck2.Gen.(sized @@ fix 313 | (fun self n -> match n with 314 | | 0 -> map leaf nat 315 | | n -> 316 | frequency 317 | [1, map leaf nat; 318 | 2, map2 node (self (n/2)) (self (n/2))] 319 | ));; 320 | 321 | (* generate a few trees with QCheck2, just to check what they look like: *) 322 | QCheck2.Gen.generate ~n:20 tree_gen;; 323 | ---- 324 | 325 | 326 | `QCheck2.Test.make` has a slightly different API than `QCheck.Test.make`, 327 | in that it accepts an optional `~print` argument and consumes generators 328 | directly built with `QCheck2.Gen`: 329 | 330 | [source,OCaml] 331 | ---- 332 | let rec print_tree = function 333 | | Leaf i -> "Leaf " ^ (string_of_int i) 334 | | Node (a,b) -> "Node (" ^ (print_tree a) ^ "," ^ (print_tree b) ^ ")";; 335 | 336 | let rec mirror_tree (t:tree) : tree = match t with 337 | | Leaf _ -> t 338 | | Node (a,b) -> node (mirror_tree b) (mirror_tree a);; 339 | 340 | let test_buggy = 341 | QCheck2.Test.make ~name:"buggy_mirror" ~count:200 ~print:print_tree 342 | tree_gen (fun t -> t = mirror_tree t);; 343 | 344 | QCheck_base_runner.run_tests [test_buggy];; 345 | ---- 346 | 347 | 348 | === Preconditions 349 | 350 | The functions `QCheck.assume` and `QCheck.(==>)` can be used for 351 | tests with preconditions. 352 | For instance, `List.hd l :: List.tl l = l` only holds for non-empty lists. 353 | Without the precondition, the property is false and will even raise 354 | an exception in some cases. 355 | 356 | [source,OCaml] 357 | ---- 358 | let test_hd_tl = 359 | QCheck.(Test.make 360 | (list int) (fun l -> 361 | assume (l <> []); 362 | l = List.hd l :: List.tl l));; 363 | 364 | QCheck_base_runner.run_tests [test_hd_tl];; 365 | ---- 366 | 367 | By including a precondition QCheck will only run a property on input 368 | satisfying `assume`'s condition, potentially generating extra test inputs. 369 | 370 | 371 | === Long tests 372 | 373 | It is often useful to have two version of a testsuite: a short one that runs 374 | reasonably fast (so that it is effectively run each time a project is built), 375 | and a long one that might be more exhaustive (but whose running time makes it 376 | impossible to run at each build). To that end, each test has a 'long' version. 377 | In the long version of a test, the number of tests to run is multiplied by 378 | the `~long_factor` argument of `QCheck.Test.make`. 379 | 380 | 381 | === Runners 382 | 383 | The module `QCheck_base_runner` defines several functions to run tests. 384 | The easiest one is probably `run_tests`, but if you write your tests in 385 | a separate executable you can also use `run_tests_main` which parses 386 | command line arguments and exits with `0` in case of success, 387 | or an error number otherwise. 388 | 389 | The module `QCheck_runner` from the `qcheck` opam package is similar, and 390 | includes compatibility with `OUnit`. 391 | 392 | 393 | === Integration within OUnit 394 | 395 | https://github.com/gildor478/ounit[OUnit] is a popular unit-testing framework 396 | for OCaml. 397 | QCheck provides a sub-library `qcheck-ounit` with some helpers, in `QCheck_ounit`, 398 | to convert its random tests into OUnit tests that can be part of a wider 399 | test-suite. 400 | 401 | [source,OCaml] 402 | ---- 403 | let passing = 404 | QCheck.Test.make ~count:1000 405 | ~name:"list_rev_is_involutive" 406 | QCheck.(list small_nat) 407 | (fun l -> List.rev (List.rev l) = l);; 408 | 409 | let failing = 410 | QCheck.Test.make ~count:10 411 | ~name:"fail_sort_id" 412 | QCheck.(list small_nat) 413 | (fun l -> l = List.sort compare l);; 414 | 415 | let _ = 416 | let open OUnit in 417 | run_test_tt_main 418 | ("tests" >::: 419 | List.map QCheck_ounit.to_ounit_test [passing; failing]) 420 | ---- 421 | 422 | 423 | === Integration within alcotest 424 | 425 | https://github.com/mirage/alcotest/[Alcotest] is a simple and colorful test framework for 426 | OCaml. QCheck now provides a sub-library `qcheck-alcotest` to 427 | easily integrate into an alcotest test suite: 428 | 429 | [source,OCaml] 430 | ---- 431 | 432 | let passing = 433 | QCheck.Test.make ~count:1000 434 | ~name:"list_rev_is_involutive" 435 | QCheck.(list small_int) 436 | (fun l -> List.rev (List.rev l) = l);; 437 | 438 | let failing = 439 | QCheck.Test.make ~count:10 440 | ~name:"fail_sort_id" 441 | QCheck.(list small_int) 442 | (fun l -> l = List.sort compare l);; 443 | 444 | let () = 445 | let suite = 446 | List.map QCheck_alcotest.to_alcotest 447 | [ passing; failing] 448 | in 449 | Alcotest.run "my test" [ 450 | "suite", suite 451 | ] 452 | ---- 453 | 454 | 455 | === Integration within Rely 456 | 457 | https://reason-native.com/docs/rely/[Rely] is a Jest-inspire native reason 458 | testing framework. @reason-native/qcheck-rely is available via NPM and provides 459 | matchers for the easy use of qCheck within Rely. 460 | 461 | [source, Reason] 462 | ---- 463 | open TestFramework; 464 | open QCheckRely; 465 | 466 | let {describe} = extendDescribe(QCheckRely.Matchers.matchers); 467 | 468 | describe("qcheck-rely", ({test}) => { 469 | test("passing test", ({expect}) => { 470 | let passing = 471 | QCheck.Test.make( 472 | ~count=1000, 473 | ~name="list_rev_is_involutive", 474 | QCheck.(list(small_int)), 475 | l => 476 | List.rev(List.rev(l)) == l 477 | ); 478 | expect.ext.qCheckTest(passing); 479 | (); 480 | }); 481 | test("failing test", ({expect}) => { 482 | let failing = 483 | QCheck.Test.make( 484 | ~count=10, ~name="fail_sort_id", QCheck.(list(small_int)), l => 485 | l == List.sort(compare, l) 486 | ); 487 | 488 | expect.ext.qCheckTest(failing); 489 | (); 490 | }); 491 | }); 492 | 493 | ---- 494 | 495 | 496 | === Deriving generators 497 | 498 | The `ppx_deriving_qcheck` opam package provides a ppx_deriver to derive QCheck 499 | generators from a type declaration: 500 | 501 | [source,OCaml] 502 | ---- 503 | type tree = Leaf of int | Node of tree * tree 504 | [@@deriving qcheck] 505 | ---- 506 | 507 | See the according https://github.com/c-cube/qcheck/tree/master/src/ppx_deriving_qcheck/[README] 508 | for more information and examples. 509 | 510 | 511 | === Usage from dune 512 | 513 | We can use the buggy test from above using the `qcheck-core` opam package: 514 | 515 | [source,OCaml] 516 | ---- 517 | (* test.ml *) 518 | let test = 519 | QCheck.Test.make ~count:1000 ~name:"my_buggy_test" 520 | QCheck.(list small_nat) 521 | (fun l -> List.rev l = l) 522 | 523 | let _ = QCheck_base_runner.run_tests_main [test] 524 | ---- 525 | 526 | with the following `dune` file (note the `qcheck-core.runner` sub-package): 527 | 528 | [source,lisp] 529 | ---- 530 | (test 531 | (name test) 532 | (modules test) 533 | (libraries qcheck-core qcheck-core.runner) 534 | ) 535 | ---- 536 | 537 | and run it with `dune exec ./test.exe` or `dune runtest`. 538 | 539 | We recommend using the `qcheck-core` package as it has a minimal set of 540 | dependencies and also avoids problems with using 541 | `(implicit_transitive_deps false)` in dune. 542 | 543 | To instead use the `qcheck` opam package and its included `QCheck_runner`: 544 | 545 | [source,OCaml] 546 | ---- 547 | (* test.ml *) 548 | let test = 549 | QCheck.Test.make ~count:1000 ~name:"my_buggy_test" 550 | QCheck.(list small_nat) 551 | (fun l -> List.rev l = l) 552 | 553 | let _ = QCheck_runner.run_tests_main [test] 554 | ---- 555 | 556 | with the following `dune` file: 557 | 558 | [source,lisp] 559 | ---- 560 | (test 561 | (name test) 562 | (modules test) 563 | (libraries qcheck) 564 | ) 565 | ---- 566 | -------------------------------------------------------------------------------- /doc/qcheck-core/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package qcheck-core) 3 | (mld_files index)) 4 | -------------------------------------------------------------------------------- /doc/qcheck-core/index.mld: -------------------------------------------------------------------------------- 1 | {0 qcheck-core} 2 | 3 | The [qcheck-core] opam package contains two libraries: 4 | 5 | - The [qcheck-core] library for defining property-based tests 6 | - The [qcheck-core.runner] library for running property-based tests 7 | 8 | {1 The [qcheck-core] library} 9 | 10 | The [qcheck-core] library exposes two toplevel modules: 11 | 12 | - {!QCheck} is the initial property-based-testing module and 13 | - {!QCheck2} is a newer property-based-testing module supporting integrated shrinking 14 | 15 | Of the two, {!QCheck} is the most battle-tested module. 16 | {!QCheck2} on the other hand offers integrated shrinking, thus 17 | removing the need for having to hand-write shrinkers. 18 | 19 | {!QCheck} tests can be ported to {!QCheck2} by following the 20 | {{!QCheck2.migration_qcheck2}migration guide}. Please 21 | file an issue if you encounter problems using either of the two 22 | modules. 23 | 24 | {1 The [qcheck-core.runner] library} 25 | 26 | The entry point of the [qcheck-core.runner] library is the {!QCheck_base_runner} module. 27 | 28 | One can run a list of property-based tests by calling either 29 | 30 | - {!QCheck_base_runner.run_tests}, which accepts a number of optional arguments, or 31 | - {!QCheck_base_runner.run_tests_main}, which can be controlled via command-line arguments 32 | -------------------------------------------------------------------------------- /doc/qcheck/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package qcheck) 3 | (mld_files index)) 4 | -------------------------------------------------------------------------------- /doc/qcheck/index.mld: -------------------------------------------------------------------------------- 1 | 2 | {1 QCheck compatibility package} 3 | 4 | 5 | This library is there to ensure compatibility with QCheck 0.8 and earlier. 6 | 7 | It has a unique module {!QCheck_runner} that merges the custom runners 8 | from [qcheck-core.runner] ({!QCheck_base_runner}) 9 | and the OUnit runners from [qcheck-ounit] ({!QCheck_ounit}) 10 | into a single module. 11 | 12 | By depending on [qcheck-core], this library also brings {!QCheck} in scope, 13 | so it can be used transparently. 14 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.2) 2 | (name qcheck) 3 | -------------------------------------------------------------------------------- /example/QCheck_runner_test.ml: -------------------------------------------------------------------------------- 1 | 2 | let passing = 3 | QCheck.Test.make ~count:100 ~long_factor:100 4 | ~name:"list_rev_is_involutive" 5 | QCheck.(list small_int) 6 | (fun l -> List.rev (List.rev l) = l);; 7 | 8 | let failing = 9 | QCheck.Test.make ~count:10 10 | ~name:"should_fail_sort_id" 11 | QCheck.(small_list small_int) 12 | (fun l -> l = List.sort compare l);; 13 | 14 | exception Error 15 | 16 | let error = 17 | QCheck.Test.make ~count:10 18 | ~name:"should_error_raise_exn" 19 | QCheck.int 20 | (fun _ -> raise Error) 21 | 22 | let collect = 23 | QCheck.Test.make ~count:100 ~long_factor:100 24 | ~name:"collect_results" 25 | QCheck.(make ~collect:string_of_int (Gen.int_bound 4)) 26 | (fun _ -> true) 27 | 28 | let stats = 29 | QCheck.Test.make ~count:100 ~long_factor:100 30 | ~name:"with_stats" 31 | QCheck.(make (Gen.int_bound 120) 32 | ~stats:[ 33 | "mod4", (fun i->i mod 4); 34 | "num", (fun i->i); 35 | ] 36 | ) 37 | (fun _ -> true) 38 | 39 | 40 | let neg_test_failing_as_expected = 41 | QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0) 42 | 43 | let neg_test_unexpected_success = 44 | QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2) 45 | 46 | let neg_test_error = 47 | QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error) 48 | 49 | let fun1 = 50 | QCheck.Test.make ~count:100 ~long_factor:100 51 | ~name:"FAIL_pred_map_commute" 52 | QCheck.(triple 53 | (small_list small_int) 54 | (fun1 Observable.int int) 55 | (fun1 Observable.int bool)) 56 | (fun (l,QCheck.Fun (_,f), QCheck.Fun (_,p)) -> 57 | List.filter p (List.map f l) = List.map f (List.filter p l)) 58 | 59 | let fun2 = 60 | QCheck.Test.make ~count:100 61 | ~name:"FAIL_fun2_pred_strings" 62 | QCheck.(fun1 Observable.string bool) 63 | (fun (QCheck.Fun (_,p)) -> 64 | not (p "some random string") || p "some other string") 65 | 66 | let bad_assume_warn = 67 | QCheck.Test.make ~count:2_000 68 | ~name:"WARN_unlikely_precond" 69 | QCheck.int 70 | (fun x -> 71 | QCheck.assume (x mod 100 = 1); 72 | true) 73 | 74 | let bad_assume_fail = 75 | QCheck.Test.make ~count:2_000 ~if_assumptions_fail:(`Fatal, 0.1) 76 | ~name:"FAIL_unlikely_precond" 77 | QCheck.int 78 | (fun x -> 79 | QCheck.assume (x mod 100 = 1); 80 | true) 81 | 82 | let int_gen = QCheck.small_nat (* int *) 83 | 84 | (* Another example (false) property *) 85 | let prop_foldleft_foldright = 86 | let open QCheck in 87 | Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 88 | (triple 89 | int_gen 90 | (list int_gen) 91 | (fun2 Observable.int Observable.int int_gen)) 92 | (fun (z,xs,f) -> 93 | let l1 = List.fold_right (Fn.apply f) xs z in 94 | let l2 = List.fold_left (Fn.apply f) z xs in 95 | if l1=l2 then true 96 | else QCheck.Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." 97 | (QCheck.Print.(list int) xs) 98 | (QCheck.Print.int l1) 99 | (QCheck.Print.int l2) 100 | ) 101 | 102 | (* Another example (false) property *) 103 | let prop_foldleft_foldright_uncurry = 104 | let open QCheck in 105 | Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 106 | (triple 107 | (fun1 Observable.(pair int int) int_gen) 108 | int_gen 109 | (list int_gen)) 110 | (fun (f,z,xs) -> 111 | List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = 112 | List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) 113 | 114 | let long_shrink = 115 | let open QCheck in 116 | let listgen = list_of_size (Gen.int_range 1000 10000) int in 117 | Test.make ~name:"long_shrink" (pair listgen listgen) 118 | (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) 119 | 120 | let find_ex = 121 | let open QCheck in 122 | Test.make ~name:"find_example" (2--50) 123 | (fun n -> 124 | let st = Random.State.make [| 0 |] in 125 | let f m = n < m && m < 2 * n in 126 | try 127 | let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in 128 | f m 129 | with No_example_found _ -> false) 130 | 131 | let find_ex_uncaught_issue_99 : _ list = 132 | let open QCheck in 133 | let t1 = 134 | let rs = make (find_example ~count:10 ~f:(fun _ -> false) Gen.int) in 135 | Test.make ~name:"FAIL_#99_1" rs (fun _ -> true) in 136 | let t2 = 137 | Test.make ~name:"should_succeed_#99_2" ~count:10 int 138 | (fun i -> i <= max_int) in 139 | [t1;t2] 140 | 141 | (* test shrinking on integers *) 142 | let shrink_int = 143 | QCheck.Test.make ~count:1000 ~name:"mod3_should_fail" 144 | QCheck.int (fun i -> i mod 3 <> 0);; 145 | 146 | let stats_negs = 147 | QCheck.(Test.make ~count:5_000 ~name:"stats_neg" 148 | (add_stat ("dist",fun x -> x) small_signed_int)) 149 | (fun _ -> true) 150 | 151 | type tree = Leaf of int | Node of tree * tree 152 | 153 | let leaf x = Leaf x 154 | let node x y = Node (x,y) 155 | 156 | let gen_tree = QCheck.Gen.(sized @@ fix 157 | (fun self n -> match n with 158 | | 0 -> map leaf nat 159 | | n -> 160 | frequency 161 | [1, map leaf nat; 162 | 2, map2 node (self (n/2)) (self (n/2))] 163 | )) 164 | 165 | let rec rev_tree = function 166 | | Node (x, y) -> Node (rev_tree y, rev_tree x) 167 | | Leaf x -> Leaf x 168 | 169 | let passing_tree_rev = 170 | QCheck.Test.make ~count:1000 171 | ~name:"tree_rev_is_involutive" 172 | QCheck.(make gen_tree) 173 | (fun tree -> rev_tree (rev_tree tree) = tree) 174 | 175 | 176 | let stats_tests = 177 | let open QCheck in 178 | [ 179 | Test.make ~name:"stat_display_test_1" ~count:1000 (add_stat ("dist",fun x -> x) small_signed_int) (fun _ -> true); 180 | Test.make ~name:"stat_display_test_2" ~count:1000 (add_stat ("dist",fun x -> x) small_nat) (fun _ -> true); 181 | Test.make ~name:"stat_display_test_3" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-43643) 435434)) (fun _ -> true); 182 | Test.make ~name:"stat_display_test_4" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-40000) 40000)) (fun _ -> true); 183 | Test.make ~name:"stat_display_test_5" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-4) 4)) (fun _ -> true); 184 | Test.make ~name:"stat_display_test_6" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-4) 17)) (fun _ -> true); 185 | Test.make ~name:"stat_display_test_7" ~count:100000 (add_stat ("dist",fun x -> x) int) (fun _ -> true); 186 | ] 187 | 188 | let () = 189 | QCheck_runner.run_tests_main ([ 190 | passing; 191 | failing; 192 | error; 193 | collect; 194 | stats; 195 | neg_test_failing_as_expected; 196 | neg_test_unexpected_success; 197 | neg_test_error; 198 | fun1; 199 | fun2; 200 | prop_foldleft_foldright; 201 | prop_foldleft_foldright_uncurry; 202 | long_shrink; 203 | find_ex; 204 | shrink_int; 205 | stats_negs; 206 | bad_assume_warn; 207 | bad_assume_fail; 208 | passing_tree_rev; 209 | ] @ find_ex_uncaught_issue_99 @ stats_tests) 210 | 211 | -------------------------------------------------------------------------------- /example/alcotest/QCheck_alcotest_test.expected.ocaml4.32: -------------------------------------------------------------------------------- 1 | qcheck random seed: 1234 2 | Testing `my test'. 3 | [OK] suite 0 list_rev_is_involutive. 4 | [FAIL] suite 1 fail_sort_id. 5 | [FAIL] suite 2 error_raise_exn. 6 | [OK] suite 3 neg test pass (failing as expected). 7 | [FAIL] suite 4 neg test unexpected success. 8 | [FAIL] suite 5 neg fail with error. 9 | [FAIL] suite 6 fail_check_err_message. 10 | [OK] suite 7 tree_rev_is_involutive. 11 | [FAIL] shrinking 0 debug_shrink. 12 | ┌──────────────────────────────────────────────────────────────────────────────┐ 13 | │ [FAIL] suite 1 fail_sort_id. │ 14 | └──────────────────────────────────────────────────────────────────────────────┘ 15 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 16 | [exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 17 | ────────────────────────────────────────────────────────────────────────────── 18 | ┌──────────────────────────────────────────────────────────────────────────────┐ 19 | │ [FAIL] suite 2 error_raise_exn. │ 20 | └──────────────────────────────────────────────────────────────────────────────┘ 21 | test `error_raise_exn` 22 | raised exception `Error` 23 | on `0 (after 31 shrink steps)` 24 | [exception] test `error_raise_exn` 25 | raised exception `Error` 26 | on `0 (after 31 shrink steps)` 27 | ────────────────────────────────────────────────────────────────────────────── 28 | ┌──────────────────────────────────────────────────────────────────────────────┐ 29 | │ [FAIL] suite 4 neg test unexpected success. │ 30 | └──────────────────────────────────────────────────────────────────────────────┘ 31 | negative test 'neg test unexpected success' succeeded unexpectedly 32 | [exception] negative test `neg test unexpected success` succeeded unexpectedly 33 | ────────────────────────────────────────────────────────────────────────────── 34 | ┌──────────────────────────────────────────────────────────────────────────────┐ 35 | │ [FAIL] suite 5 neg fail with error. │ 36 | └──────────────────────────────────────────────────────────────────────────────┘ 37 | test `neg fail with error` 38 | raised exception `Error` 39 | on `0 (after 7 shrink steps)` 40 | [exception] test `neg fail with error` 41 | raised exception `Error` 42 | on `0 (after 7 shrink steps)` 43 | ────────────────────────────────────────────────────────────────────────────── 44 | ┌──────────────────────────────────────────────────────────────────────────────┐ 45 | │ [FAIL] suite 6 fail_check_err_message. │ 46 | └──────────────────────────────────────────────────────────────────────────────┘ 47 | test `fail_check_err_message` failed on ≥ 1 cases: 48 | 0 (after 7 shrink steps) 49 | this 50 | will 51 | always 52 | fail 53 | [exception] test `fail_check_err_message` failed on ≥ 1 cases: 54 | 0 (after 7 shrink steps) 55 | this 56 | will 57 | always 58 | fail 59 | ────────────────────────────────────────────────────────────────────────────── 60 | ┌──────────────────────────────────────────────────────────────────────────────┐ 61 | │ [FAIL] shrinking 0 debug_shrink. │ 62 | └──────────────────────────────────────────────────────────────────────────────┘ 63 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 64 | Test debug_shrink successfully shrunk counter example (step 0) to: 65 | (3, 1) 66 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 67 | Test debug_shrink successfully shrunk counter example (step 1) to: 68 | (2, 1) 69 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 70 | Test debug_shrink successfully shrunk counter example (step 2) to: 71 | (2, 0) 72 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 73 | Test debug_shrink successfully shrunk counter example (step 3) to: 74 | (1, 0) 75 | law debug_shrink: 2 relevant cases (2 total) 76 | test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps) 77 | [exception] test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps) 78 | ────────────────────────────────────────────────────────────────────────────── 79 | 6 failures! 9 tests run. 80 | -------------------------------------------------------------------------------- /example/alcotest/QCheck_alcotest_test.expected.ocaml4.64: -------------------------------------------------------------------------------- 1 | qcheck random seed: 1234 2 | Testing `my test'. 3 | [OK] suite 0 list_rev_is_involutive. 4 | [FAIL] suite 1 fail_sort_id. 5 | [FAIL] suite 2 error_raise_exn. 6 | [OK] suite 3 neg test pass (failing as expected). 7 | [FAIL] suite 4 neg test unexpected success. 8 | [FAIL] suite 5 neg fail with error. 9 | [FAIL] suite 6 fail_check_err_message. 10 | [OK] suite 7 tree_rev_is_involutive. 11 | [FAIL] shrinking 0 debug_shrink. 12 | ┌──────────────────────────────────────────────────────────────────────────────┐ 13 | │ [FAIL] suite 1 fail_sort_id. │ 14 | └──────────────────────────────────────────────────────────────────────────────┘ 15 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 16 | [exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 17 | ────────────────────────────────────────────────────────────────────────────── 18 | ┌──────────────────────────────────────────────────────────────────────────────┐ 19 | │ [FAIL] suite 2 error_raise_exn. │ 20 | └──────────────────────────────────────────────────────────────────────────────┘ 21 | test `error_raise_exn` 22 | raised exception `Error` 23 | on `0 (after 63 shrink steps)` 24 | [exception] test `error_raise_exn` 25 | raised exception `Error` 26 | on `0 (after 63 shrink steps)` 27 | ────────────────────────────────────────────────────────────────────────────── 28 | ┌──────────────────────────────────────────────────────────────────────────────┐ 29 | │ [FAIL] suite 4 neg test unexpected success. │ 30 | └──────────────────────────────────────────────────────────────────────────────┘ 31 | negative test 'neg test unexpected success' succeeded unexpectedly 32 | [exception] negative test `neg test unexpected success` succeeded unexpectedly 33 | ────────────────────────────────────────────────────────────────────────────── 34 | ┌──────────────────────────────────────────────────────────────────────────────┐ 35 | │ [FAIL] suite 5 neg fail with error. │ 36 | └──────────────────────────────────────────────────────────────────────────────┘ 37 | test `neg fail with error` 38 | raised exception `Error` 39 | on `0 (after 7 shrink steps)` 40 | [exception] test `neg fail with error` 41 | raised exception `Error` 42 | on `0 (after 7 shrink steps)` 43 | ────────────────────────────────────────────────────────────────────────────── 44 | ┌──────────────────────────────────────────────────────────────────────────────┐ 45 | │ [FAIL] suite 6 fail_check_err_message. │ 46 | └──────────────────────────────────────────────────────────────────────────────┘ 47 | test `fail_check_err_message` failed on ≥ 1 cases: 48 | 0 (after 7 shrink steps) 49 | this 50 | will 51 | always 52 | fail 53 | [exception] test `fail_check_err_message` failed on ≥ 1 cases: 54 | 0 (after 7 shrink steps) 55 | this 56 | will 57 | always 58 | fail 59 | ────────────────────────────────────────────────────────────────────────────── 60 | ┌──────────────────────────────────────────────────────────────────────────────┐ 61 | │ [FAIL] shrinking 0 debug_shrink. │ 62 | └──────────────────────────────────────────────────────────────────────────────┘ 63 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 64 | Test debug_shrink successfully shrunk counter example (step 0) to: 65 | (3, 1) 66 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 67 | Test debug_shrink successfully shrunk counter example (step 1) to: 68 | (2, 1) 69 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 70 | Test debug_shrink successfully shrunk counter example (step 2) to: 71 | (2, 0) 72 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 73 | Test debug_shrink successfully shrunk counter example (step 3) to: 74 | (1, 0) 75 | law debug_shrink: 2 relevant cases (2 total) 76 | test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps) 77 | [exception] test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps) 78 | ────────────────────────────────────────────────────────────────────────────── 79 | 6 failures! 9 tests run. 80 | -------------------------------------------------------------------------------- /example/alcotest/QCheck_alcotest_test.expected.ocaml5.32: -------------------------------------------------------------------------------- 1 | qcheck random seed: 1234 2 | Testing `my test'. 3 | [OK] suite 0 list_rev_is_involutive. 4 | [FAIL] suite 1 fail_sort_id. 5 | [FAIL] suite 2 error_raise_exn. 6 | [OK] suite 3 neg test pass (failing as expected). 7 | [FAIL] suite 4 neg test unexpected success. 8 | [FAIL] suite 5 neg fail with error. 9 | [FAIL] suite 6 fail_check_err_message. 10 | [OK] suite 7 tree_rev_is_involutive. 11 | [FAIL] shrinking 0 debug_shrink. 12 | ┌──────────────────────────────────────────────────────────────────────────────┐ 13 | │ [FAIL] suite 1 fail_sort_id. │ 14 | └──────────────────────────────────────────────────────────────────────────────┘ 15 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 16 | [exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 17 | ────────────────────────────────────────────────────────────────────────────── 18 | ┌──────────────────────────────────────────────────────────────────────────────┐ 19 | │ [FAIL] suite 2 error_raise_exn. │ 20 | └──────────────────────────────────────────────────────────────────────────────┘ 21 | test `error_raise_exn` 22 | raised exception `Error` 23 | on `0 (after 30 shrink steps)` 24 | [exception] test `error_raise_exn` 25 | raised exception `Error` 26 | on `0 (after 30 shrink steps)` 27 | ────────────────────────────────────────────────────────────────────────────── 28 | ┌──────────────────────────────────────────────────────────────────────────────┐ 29 | │ [FAIL] suite 4 neg test unexpected success. │ 30 | └──────────────────────────────────────────────────────────────────────────────┘ 31 | negative test 'neg test unexpected success' succeeded unexpectedly 32 | [exception] negative test `neg test unexpected success` succeeded unexpectedly 33 | ────────────────────────────────────────────────────────────────────────────── 34 | ┌──────────────────────────────────────────────────────────────────────────────┐ 35 | │ [FAIL] suite 5 neg fail with error. │ 36 | └──────────────────────────────────────────────────────────────────────────────┘ 37 | test `neg fail with error` 38 | raised exception `Error` 39 | on `0 (after 7 shrink steps)` 40 | [exception] test `neg fail with error` 41 | raised exception `Error` 42 | on `0 (after 7 shrink steps)` 43 | ────────────────────────────────────────────────────────────────────────────── 44 | ┌──────────────────────────────────────────────────────────────────────────────┐ 45 | │ [FAIL] suite 6 fail_check_err_message. │ 46 | └──────────────────────────────────────────────────────────────────────────────┘ 47 | test `fail_check_err_message` failed on ≥ 1 cases: 48 | 0 (after 7 shrink steps) 49 | this 50 | will 51 | always 52 | fail 53 | [exception] test `fail_check_err_message` failed on ≥ 1 cases: 54 | 0 (after 7 shrink steps) 55 | this 56 | will 57 | always 58 | fail 59 | ────────────────────────────────────────────────────────────────────────────── 60 | ┌──────────────────────────────────────────────────────────────────────────────┐ 61 | │ [FAIL] shrinking 0 debug_shrink. │ 62 | └──────────────────────────────────────────────────────────────────────────────┘ 63 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 64 | Test debug_shrink successfully shrunk counter example (step 0) to: 65 | (2, 3) 66 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 67 | Test debug_shrink successfully shrunk counter example (step 1) to: 68 | (1, 3) 69 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 70 | Test debug_shrink successfully shrunk counter example (step 2) to: 71 | (0, 3) 72 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 73 | Test debug_shrink successfully shrunk counter example (step 3) to: 74 | (0, 2) 75 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 76 | Test debug_shrink successfully shrunk counter example (step 4) to: 77 | (0, 1) 78 | law debug_shrink: 1 relevant cases (1 total) 79 | test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps) 80 | [exception] test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps) 81 | ────────────────────────────────────────────────────────────────────────────── 82 | 6 failures! 9 tests run. 83 | -------------------------------------------------------------------------------- /example/alcotest/QCheck_alcotest_test.expected.ocaml5.64: -------------------------------------------------------------------------------- 1 | qcheck random seed: 1234 2 | Testing `my test'. 3 | [OK] suite 0 list_rev_is_involutive. 4 | [FAIL] suite 1 fail_sort_id. 5 | [FAIL] suite 2 error_raise_exn. 6 | [OK] suite 3 neg test pass (failing as expected). 7 | [FAIL] suite 4 neg test unexpected success. 8 | [FAIL] suite 5 neg fail with error. 9 | [FAIL] suite 6 fail_check_err_message. 10 | [OK] suite 7 tree_rev_is_involutive. 11 | [FAIL] shrinking 0 debug_shrink. 12 | ┌──────────────────────────────────────────────────────────────────────────────┐ 13 | │ [FAIL] suite 1 fail_sort_id. │ 14 | └──────────────────────────────────────────────────────────────────────────────┘ 15 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 16 | [exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 17 | ────────────────────────────────────────────────────────────────────────────── 18 | ┌──────────────────────────────────────────────────────────────────────────────┐ 19 | │ [FAIL] suite 2 error_raise_exn. │ 20 | └──────────────────────────────────────────────────────────────────────────────┘ 21 | test `error_raise_exn` 22 | raised exception `Error` 23 | on `0 (after 62 shrink steps)` 24 | [exception] test `error_raise_exn` 25 | raised exception `Error` 26 | on `0 (after 62 shrink steps)` 27 | ────────────────────────────────────────────────────────────────────────────── 28 | ┌──────────────────────────────────────────────────────────────────────────────┐ 29 | │ [FAIL] suite 4 neg test unexpected success. │ 30 | └──────────────────────────────────────────────────────────────────────────────┘ 31 | negative test 'neg test unexpected success' succeeded unexpectedly 32 | [exception] negative test `neg test unexpected success` succeeded unexpectedly 33 | ────────────────────────────────────────────────────────────────────────────── 34 | ┌──────────────────────────────────────────────────────────────────────────────┐ 35 | │ [FAIL] suite 5 neg fail with error. │ 36 | └──────────────────────────────────────────────────────────────────────────────┘ 37 | test `neg fail with error` 38 | raised exception `Error` 39 | on `0 (after 7 shrink steps)` 40 | [exception] test `neg fail with error` 41 | raised exception `Error` 42 | on `0 (after 7 shrink steps)` 43 | ────────────────────────────────────────────────────────────────────────────── 44 | ┌──────────────────────────────────────────────────────────────────────────────┐ 45 | │ [FAIL] suite 6 fail_check_err_message. │ 46 | └──────────────────────────────────────────────────────────────────────────────┘ 47 | test `fail_check_err_message` failed on ≥ 1 cases: 48 | 0 (after 7 shrink steps) 49 | this 50 | will 51 | always 52 | fail 53 | [exception] test `fail_check_err_message` failed on ≥ 1 cases: 54 | 0 (after 7 shrink steps) 55 | this 56 | will 57 | always 58 | fail 59 | ────────────────────────────────────────────────────────────────────────────── 60 | ┌──────────────────────────────────────────────────────────────────────────────┐ 61 | │ [FAIL] shrinking 0 debug_shrink. │ 62 | └──────────────────────────────────────────────────────────────────────────────┘ 63 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 64 | Test debug_shrink successfully shrunk counter example (step 0) to: 65 | (2, 3) 66 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 67 | Test debug_shrink successfully shrunk counter example (step 1) to: 68 | (1, 3) 69 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 70 | Test debug_shrink successfully shrunk counter example (step 2) to: 71 | (0, 3) 72 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 73 | Test debug_shrink successfully shrunk counter example (step 3) to: 74 | (0, 2) 75 | ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 76 | Test debug_shrink successfully shrunk counter example (step 4) to: 77 | (0, 1) 78 | law debug_shrink: 1 relevant cases (1 total) 79 | test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps) 80 | [exception] test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps) 81 | ────────────────────────────────────────────────────────────────────────────── 82 | 6 failures! 9 tests run. 83 | -------------------------------------------------------------------------------- /example/alcotest/QCheck_alcotest_test.ml: -------------------------------------------------------------------------------- 1 | let passing = 2 | QCheck.Test.make ~count:1000 3 | ~name:"list_rev_is_involutive" 4 | QCheck.(list small_int) 5 | (fun l -> List.rev (List.rev l) = l);; 6 | 7 | let failing = 8 | QCheck.Test.make ~count:10 9 | ~name:"fail_sort_id" 10 | QCheck.(list small_int) 11 | (fun l -> l = List.sort compare l);; 12 | 13 | exception Error 14 | 15 | let error = 16 | QCheck.Test.make ~count:10 17 | ~name:"error_raise_exn" 18 | QCheck.int 19 | (fun _ -> raise Error) 20 | 21 | let neg_test_failing_as_expected = 22 | QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0) 23 | 24 | let neg_test_unexpected_success = 25 | QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2) 26 | 27 | let neg_test_error = 28 | QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error) 29 | 30 | let simple_qcheck = 31 | QCheck.Test.make ~name:"fail_check_err_message" 32 | ~count: 100 33 | QCheck.small_int 34 | (fun _ -> QCheck.Test.fail_reportf "@[this@ will@ always@ fail@]") 35 | 36 | type tree = Leaf of int | Node of tree * tree 37 | 38 | let leaf x = Leaf x 39 | let node x y = Node (x,y) 40 | 41 | let gen_tree = QCheck.Gen.(sized @@ fix 42 | (fun self n -> match n with 43 | | 0 -> map leaf nat 44 | | n -> 45 | frequency 46 | [1, map leaf nat; 47 | 2, map2 node (self (n/2)) (self (n/2))] 48 | )) 49 | 50 | let rec rev_tree = function 51 | | Node (x, y) -> Node (rev_tree y, rev_tree x) 52 | | Leaf x -> Leaf x 53 | 54 | let passing_tree_rev = 55 | QCheck.Test.make ~count:1000 56 | ~name:"tree_rev_is_involutive" 57 | QCheck.(make gen_tree) 58 | (fun tree -> rev_tree (rev_tree tree) = tree) 59 | 60 | let debug_shrink = 61 | QCheck.Test.make ~count:10 62 | ~name:"debug_shrink" 63 | (* we use a very constrained test to have a smaller shrinking tree *) 64 | QCheck.(pair (1 -- 3) (1 -- 3)) 65 | (fun (a, b) -> a = b);; 66 | 67 | let () = 68 | Printexc.record_backtrace true; 69 | let module A = Alcotest in 70 | let suite = 71 | List.map QCheck_alcotest.to_alcotest 72 | [ passing; failing; error; 73 | neg_test_failing_as_expected; neg_test_unexpected_success; neg_test_error; 74 | simple_qcheck; passing_tree_rev ] 75 | in 76 | A.run ~show_errors:true "my test" [ 77 | "suite", suite; 78 | "shrinking", [ 79 | QCheck_alcotest.to_alcotest ~verbose:true ~debug_shrink:(Some stdout) debug_shrink 80 | ]; 81 | ]; 82 | -------------------------------------------------------------------------------- /example/alcotest/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) 3 | (action (copy QCheck_alcotest_test.expected.ocaml5.64 QCheck_alcotest_test.expected))) 4 | 5 | (rule 6 | (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) 7 | (action (copy QCheck_alcotest_test.expected.ocaml5.32 QCheck_alcotest_test.expected))) 8 | 9 | (rule 10 | (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) 11 | (action (copy QCheck_alcotest_test.expected.ocaml4.64 QCheck_alcotest_test.expected))) 12 | 13 | (rule 14 | (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) 15 | (action (copy QCheck_alcotest_test.expected.ocaml4.32 QCheck_alcotest_test.expected))) 16 | 17 | (executable 18 | (name QCheck_alcotest_test) 19 | (libraries qcheck-core qcheck-alcotest alcotest)) 20 | 21 | (rule 22 | (targets QCheck_alcotest_test.output) 23 | (deps ./QCheck_alcotest_test.exe) 24 | (enabled_if (= %{os_type} "Unix")) 25 | (action 26 | (with-accepted-exit-codes 1 27 | (setenv CI false ; Don't run tests as if Alcotest was run in CI 28 | (setenv QCHECK_SEED 1234 29 | (with-stdout-to %{targets} 30 | (run ./run_alcotest.sh --color=never))))))) 31 | 32 | (rule 33 | (alias runtest) 34 | (package qcheck-alcotest) 35 | (enabled_if (= %{os_type} "Unix")) 36 | (action (diff QCheck_alcotest_test.expected QCheck_alcotest_test.output))) 37 | -------------------------------------------------------------------------------- /example/alcotest/run_alcotest.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # custom script to run qcheck-alcotest and filter non reproducible parts 4 | 5 | OUT=`./QCheck_alcotest_test.exe $@` 6 | CODE=$? 7 | 8 | # remove non deterministic output 9 | echo "$OUT" | grep -v 'This run has ID' \ 10 | | grep -v 'Full test results in' \ 11 | | grep -v 'Logs saved to' \ 12 | | grep -v 'Raised at ' \ 13 | | grep -v 'Called from ' \ 14 | | sed 's/! in .*s\./!/' \ 15 | | sed 's/`.*.Error`/`Error`/g' \ 16 | | sed 's/[ \t]*$//g' \ 17 | | tr -s "\n" 18 | exit $CODE 19 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) 3 | (action (copy QCheck_runner_test.expected.ocaml5.64 QCheck_runner_test.expected))) 4 | 5 | (rule 6 | (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) 7 | (action (copy QCheck_runner_test.expected.ocaml5.32 QCheck_runner_test.expected))) 8 | 9 | (rule 10 | (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) 11 | (action (copy QCheck_runner_test.expected.ocaml4.64 QCheck_runner_test.expected))) 12 | 13 | (rule 14 | (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) 15 | (action (copy QCheck_runner_test.expected.ocaml4.32 QCheck_runner_test.expected))) 16 | 17 | ;; implicitly compared against QCheck_runner_test.expected 18 | (test 19 | (enabled_if (= %{os_type} "Unix")) 20 | (name QCheck_runner_test) 21 | (modules QCheck_runner_test) 22 | (package qcheck) 23 | (libraries qcheck) 24 | (action (with-accepted-exit-codes 1 (run ./%{test} --no-colors -s 1234)))) 25 | -------------------------------------------------------------------------------- /example/ounit/QCheck_ounit_test.expected.ocaml4.32: -------------------------------------------------------------------------------- 1 | .FE.FEF. 2 | ============================================================================== 3 | Error: tests:5:neg fail with error. 4 | 5 | Error: tests:5:neg fail with error (in the log). 6 | 7 | 8 | test `neg fail with error` 9 | raised exception `Dune__exe__QCheck_ounit_test.Error` 10 | on `0 (after 7 shrink steps)` 11 | 12 | ------------------------------------------------------------------------------ 13 | ============================================================================== 14 | Error: tests:2:error_raise_exn. 15 | 16 | Error: tests:2:error_raise_exn (in the log). 17 | 18 | 19 | test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error` 20 | on `0 (after 31 shrink steps)` 21 | 22 | ------------------------------------------------------------------------------ 23 | ============================================================================== 24 | Error: tests:6:fail_check_err_message. 25 | 26 | Error: tests:6:fail_check_err_message (in the log). 27 | 28 | 29 | 30 | test `fail_check_err_message` failed on ≥ 1 cases: 31 | 0 (after 7 shrink steps) 32 | this 33 | will 34 | always 35 | fail 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | ============================================================================== 41 | Error: tests:4:neg test unexpected success. 42 | 43 | Error: tests:4:neg test unexpected success (in the log). 44 | 45 | 46 | 47 | negative test 'neg test unexpected success' succeeded unexpectedly 48 | 49 | ------------------------------------------------------------------------------ 50 | ============================================================================== 51 | Error: tests:1:fail_sort_id. 52 | 53 | Error: tests:1:fail_sort_id (in the log). 54 | 55 | 56 | 57 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | Ran: 8 tests in: seconds. 62 | FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip: 0 Todo: 0 Timeouts: 0. 63 | -------------------------------------------------------------------------------- /example/ounit/QCheck_ounit_test.expected.ocaml4.64: -------------------------------------------------------------------------------- 1 | .FE.FEF. 2 | ============================================================================== 3 | Error: tests:5:neg fail with error. 4 | 5 | Error: tests:5:neg fail with error (in the log). 6 | 7 | 8 | test `neg fail with error` 9 | raised exception `Dune__exe__QCheck_ounit_test.Error` 10 | on `0 (after 7 shrink steps)` 11 | 12 | ------------------------------------------------------------------------------ 13 | ============================================================================== 14 | Error: tests:2:error_raise_exn. 15 | 16 | Error: tests:2:error_raise_exn (in the log). 17 | 18 | 19 | test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error` 20 | on `0 (after 63 shrink steps)` 21 | 22 | ------------------------------------------------------------------------------ 23 | ============================================================================== 24 | Error: tests:6:fail_check_err_message. 25 | 26 | Error: tests:6:fail_check_err_message (in the log). 27 | 28 | 29 | 30 | test `fail_check_err_message` failed on ≥ 1 cases: 31 | 0 (after 7 shrink steps) 32 | this 33 | will 34 | always 35 | fail 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | ============================================================================== 41 | Error: tests:4:neg test unexpected success. 42 | 43 | Error: tests:4:neg test unexpected success (in the log). 44 | 45 | 46 | 47 | negative test 'neg test unexpected success' succeeded unexpectedly 48 | 49 | ------------------------------------------------------------------------------ 50 | ============================================================================== 51 | Error: tests:1:fail_sort_id. 52 | 53 | Error: tests:1:fail_sort_id (in the log). 54 | 55 | 56 | 57 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps) 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | Ran: 8 tests in: seconds. 62 | FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip: 0 Todo: 0 Timeouts: 0. 63 | -------------------------------------------------------------------------------- /example/ounit/QCheck_ounit_test.expected.ocaml5.32: -------------------------------------------------------------------------------- 1 | .FE.FEF. 2 | ============================================================================== 3 | Error: tests:5:neg fail with error. 4 | 5 | Error: tests:5:neg fail with error (in the log). 6 | 7 | 8 | test `neg fail with error` 9 | raised exception `Dune__exe__QCheck_ounit_test.Error` 10 | on `0 (after 7 shrink steps)` 11 | 12 | ------------------------------------------------------------------------------ 13 | ============================================================================== 14 | Error: tests:2:error_raise_exn. 15 | 16 | Error: tests:2:error_raise_exn (in the log). 17 | 18 | 19 | test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error` 20 | on `0 (after 30 shrink steps)` 21 | 22 | ------------------------------------------------------------------------------ 23 | ============================================================================== 24 | Error: tests:6:fail_check_err_message. 25 | 26 | Error: tests:6:fail_check_err_message (in the log). 27 | 28 | 29 | 30 | test `fail_check_err_message` failed on ≥ 1 cases: 31 | 0 (after 7 shrink steps) 32 | this 33 | will 34 | always 35 | fail 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | ============================================================================== 41 | Error: tests:4:neg test unexpected success. 42 | 43 | Error: tests:4:neg test unexpected success (in the log). 44 | 45 | 46 | 47 | negative test 'neg test unexpected success' succeeded unexpectedly 48 | 49 | ------------------------------------------------------------------------------ 50 | ============================================================================== 51 | Error: tests:1:fail_sort_id. 52 | 53 | Error: tests:1:fail_sort_id (in the log). 54 | 55 | 56 | 57 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | Ran: 8 tests in: seconds. 62 | FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip: 0 Todo: 0 Timeouts: 0. 63 | -------------------------------------------------------------------------------- /example/ounit/QCheck_ounit_test.expected.ocaml5.64: -------------------------------------------------------------------------------- 1 | .FE.FEF. 2 | ============================================================================== 3 | Error: tests:5:neg fail with error. 4 | 5 | Error: tests:5:neg fail with error (in the log). 6 | 7 | 8 | test `neg fail with error` 9 | raised exception `Dune__exe__QCheck_ounit_test.Error` 10 | on `0 (after 7 shrink steps)` 11 | 12 | ------------------------------------------------------------------------------ 13 | ============================================================================== 14 | Error: tests:2:error_raise_exn. 15 | 16 | Error: tests:2:error_raise_exn (in the log). 17 | 18 | 19 | test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error` 20 | on `0 (after 62 shrink steps)` 21 | 22 | ------------------------------------------------------------------------------ 23 | ============================================================================== 24 | Error: tests:6:fail_check_err_message. 25 | 26 | Error: tests:6:fail_check_err_message (in the log). 27 | 28 | 29 | 30 | test `fail_check_err_message` failed on ≥ 1 cases: 31 | 0 (after 7 shrink steps) 32 | this 33 | will 34 | always 35 | fail 36 | 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | ============================================================================== 41 | Error: tests:4:neg test unexpected success. 42 | 43 | Error: tests:4:neg test unexpected success (in the log). 44 | 45 | 46 | 47 | negative test 'neg test unexpected success' succeeded unexpectedly 48 | 49 | ------------------------------------------------------------------------------ 50 | ============================================================================== 51 | Error: tests:1:fail_sort_id. 52 | 53 | Error: tests:1:fail_sort_id (in the log). 54 | 55 | 56 | 57 | test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps) 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | Ran: 8 tests in: seconds. 62 | FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip: 0 Todo: 0 Timeouts: 0. 63 | -------------------------------------------------------------------------------- /example/ounit/QCheck_ounit_test.ml: -------------------------------------------------------------------------------- 1 | (* Tests to check integration with the 'OUnit2.test' interface *) 2 | 3 | let passing = 4 | QCheck.Test.make ~count:1000 5 | ~name:"list_rev_is_involutive" 6 | QCheck.(list small_int) 7 | (fun l -> List.rev (List.rev l) = l);; 8 | 9 | let failing = 10 | QCheck.Test.make ~count:10 11 | ~name:"fail_sort_id" 12 | QCheck.(list small_int) 13 | (fun l -> l = List.sort compare l);; 14 | 15 | exception Error 16 | 17 | let error = 18 | QCheck.Test.make ~count:10 19 | ~name:"error_raise_exn" 20 | QCheck.int 21 | (fun _ -> raise Error) 22 | 23 | let simple_qcheck = 24 | QCheck.Test.make ~name:"fail_check_err_message" 25 | ~count: 100 26 | QCheck.small_int 27 | (fun _ -> QCheck.Test.fail_reportf "@[this@ will@ always@ fail@]") 28 | 29 | let neg_test_failing_as_expected = 30 | QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0) 31 | 32 | let neg_test_unexpected_success = 33 | QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2) 34 | 35 | let neg_test_error = 36 | QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error) 37 | 38 | 39 | type tree = Leaf of int | Node of tree * tree 40 | 41 | let leaf x = Leaf x 42 | let node x y = Node (x,y) 43 | 44 | let gen_tree = QCheck.Gen.(sized @@ fix 45 | (fun self n -> match n with 46 | | 0 -> map leaf nat 47 | | n -> 48 | frequency 49 | [1, map leaf nat; 50 | 2, map2 node (self (n/2)) (self (n/2))] 51 | )) 52 | 53 | let rec rev_tree = function 54 | | Node (x, y) -> Node (rev_tree y, rev_tree x) 55 | | Leaf x -> Leaf x 56 | 57 | let passing_tree_rev = 58 | QCheck.Test.make ~count:1000 59 | ~name:"tree_rev_is_involutive" 60 | QCheck.(make gen_tree) 61 | (fun tree -> rev_tree (rev_tree tree) = tree) 62 | 63 | let () = 64 | Printexc.record_backtrace true; 65 | let open OUnit2 in 66 | run_test_tt_main 67 | ("tests" >::: 68 | List.map QCheck_ounit.to_ounit2_test 69 | [passing; failing; error; 70 | neg_test_failing_as_expected; neg_test_unexpected_success; neg_test_error; 71 | simple_qcheck; passing_tree_rev]) 72 | -------------------------------------------------------------------------------- /example/ounit/QCheck_test.ml: -------------------------------------------------------------------------------- 1 | (* Tests to check integration with the 'OUnit.test' interface *) 2 | 3 | let (|>) x f = f x 4 | 5 | module Q = QCheck 6 | 7 | let passing = 8 | Q.Test.make ~count:1000 ~long_factor:2 9 | ~name:"list_rev_is_involutive" 10 | Q.(list small_int) 11 | (fun l -> List.rev (List.rev l) = l);; 12 | 13 | let failing = 14 | Q.Test.make ~count:10 15 | ~name:"should_fail_sort_id" 16 | Q.(small_list small_int) 17 | (fun l -> l = List.sort compare l);; 18 | 19 | exception Error 20 | 21 | let error = 22 | Q.Test.make ~count:10 23 | ~name:"should_error_raise_exn" 24 | Q.int 25 | (fun _ -> raise Error) 26 | 27 | let neg_test_failing_as_expected = 28 | Q.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0) 29 | 30 | let neg_test_unexpected_success = 31 | Q.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2) 32 | 33 | let neg_test_error = 34 | Q.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error) 35 | 36 | open OUnit 37 | 38 | let regression_23 = 39 | "issue_23" >:: 40 | (fun () -> 41 | let l = Q.Gen.(generate ~n:100_000 char) in 42 | OUnit.assert_bool "must contain '\255'" 43 | (List.exists (fun c->c = '\255') l) 44 | ) 45 | 46 | let regressions = [ regression_23 ] 47 | let others = 48 | [ passing; 49 | failing; 50 | error; 51 | neg_test_failing_as_expected; 52 | neg_test_unexpected_success; 53 | neg_test_error; 54 | ] |> List.map (fun t -> QCheck_ounit.to_ounit_test t) 55 | 56 | let suite = 57 | "tests" >::: (regressions @ others) 58 | 59 | let () = 60 | try exit (QCheck_ounit.run suite) 61 | with Arg.Bad msg -> print_endline msg; exit 1 62 | | Arg.Help msg -> print_endline msg; exit 0 63 | 64 | -------------------------------------------------------------------------------- /example/ounit/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names QCheck_ounit_test QCheck_test) 3 | (libraries ounit2 qcheck-ounit)) 4 | 5 | (rule 6 | (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) 7 | (action (copy QCheck_ounit_test.expected.ocaml5.64 QCheck_ounit_test.expected))) 8 | 9 | (rule 10 | (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) 11 | (action (copy QCheck_ounit_test.expected.ocaml5.32 QCheck_ounit_test.expected))) 12 | 13 | (rule 14 | (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) 15 | (action (copy QCheck_ounit_test.expected.ocaml4.64 QCheck_ounit_test.expected))) 16 | 17 | (rule 18 | (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) 19 | (action (copy QCheck_ounit_test.expected.ocaml4.32 QCheck_ounit_test.expected))) 20 | 21 | (rule 22 | (targets QCheck_ounit_test.output) 23 | (deps ./QCheck_ounit_test.exe) 24 | (enabled_if (= %{os_type} "Unix")) 25 | (action 26 | (with-accepted-exit-codes 1 27 | (with-stdout-to %{targets} 28 | (run ./run_ounit.sh -runner=sequential -seed 1234))))) 29 | 30 | (rule 31 | (alias runtest) 32 | (package qcheck-ounit) 33 | (enabled_if (= %{os_type} "Unix")) 34 | (action (diff QCheck_ounit_test.expected QCheck_ounit_test.output))) 35 | -------------------------------------------------------------------------------- /example/ounit/run_ounit.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # custom script to run qcheck-ounit and filter non reproducible parts 4 | 5 | OUT=`./QCheck_ounit_test.exe $@` 6 | CODE=$? 7 | 8 | # remove non deterministic output 9 | echo "$OUT" \ 10 | | grep -v 'File .*, line .*' \ 11 | | grep -v 'Called from ' \ 12 | | grep -v 'Raised at ' \ 13 | | grep -v '(in the code)' \ 14 | | sed 's/in: .*seconds/in: seconds/' 15 | exit $CODE 16 | -------------------------------------------------------------------------------- /ppx_deriving_qcheck.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "ppx_deriving_qcheck" 3 | version: "0.7" 4 | license: "BSD-2-Clause" 5 | synopsis: "PPX Deriver for QCheck" 6 | 7 | maintainer: "valentin.chb@gmail.com" 8 | author: [ "the qcheck contributors" ] 9 | 10 | depends: [ 11 | "dune" {>= "2.8.0"} 12 | "ocaml" {>= "4.08.0"} 13 | "qcheck-core" {>= "0.24"} 14 | "ppxlib" {>= "0.36.0"} 15 | "ppx_deriving" {>= "6.1.0"} 16 | "odoc" {with-doc} 17 | "alcotest" {with-test & >= "1.4.0" } 18 | "qcheck-alcotest" {with-test & >= "0.24"} 19 | ] 20 | 21 | build: [ 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 24 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 25 | ] 26 | 27 | homepage: "https://github.com/c-cube/qcheck/" 28 | bug-reports: "https://github.com/c-cube/qcheck/-/issues" 29 | dev-repo: "git+https://github.com/c-cube/qcheck.git" 30 | x-maintenance-intent: ["(latest)"] 31 | -------------------------------------------------------------------------------- /qcheck-alcotest.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "simon.cruanes.2007@m4x.org" 3 | author: [ "the qcheck contributors" ] 4 | homepage: "https://github.com/c-cube/qcheck/" 5 | license: "BSD-2-Clause" 6 | synopsis: "Alcotest backend for qcheck" 7 | doc: ["http://c-cube.github.io/qcheck/"] 8 | version: "0.25" 9 | tags: [ 10 | "test" 11 | "quickcheck" 12 | "qcheck" 13 | "alcotest" 14 | ] 15 | build: [ 16 | ["dune" "build" "-p" name "-j" jobs] 17 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 18 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 19 | ] 20 | depends: [ 21 | "dune" { >= "2.8.0" } 22 | "base-unix" 23 | "qcheck-core" { = version } 24 | "alcotest" {>= "1.2.0"} 25 | "odoc" {with-doc} 26 | "ocaml" {>= "4.08.0"} 27 | ] 28 | dev-repo: "git+https://github.com/c-cube/qcheck.git" 29 | bug-reports: "https://github.com/c-cube/qcheck/issues" 30 | x-maintenance-intent: ["(latest)"] 31 | -------------------------------------------------------------------------------- /qcheck-core.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "simon.cruanes.2007@m4x.org" 3 | author: [ "the qcheck contributors" ] 4 | homepage: "https://github.com/c-cube/qcheck/" 5 | license: "BSD-2-Clause" 6 | synopsis: "Core qcheck library" 7 | doc: ["http://c-cube.github.io/qcheck/"] 8 | version: "0.25" 9 | tags: [ 10 | "test" 11 | "property" 12 | "quickcheck" 13 | ] 14 | build: [ 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 17 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 18 | ] 19 | depends: [ 20 | "dune" { >= "2.8.0" } 21 | "base-unix" 22 | "alcotest" {with-test & >= "1.2.0"} 23 | "odoc" {with-doc} 24 | "ocaml" {>= "4.08.0"} 25 | ] 26 | dev-repo: "git+https://github.com/c-cube/qcheck.git" 27 | x-maintenance-intent: ["(latest)"] 28 | bug-reports: "https://github.com/c-cube/qcheck/issues" 29 | conflicts: [ 30 | "ounit" { < "2.0" } 31 | ] 32 | -------------------------------------------------------------------------------- /qcheck-ounit.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "simon.cruanes.2007@m4x.org" 3 | author: [ "the qcheck contributors" ] 4 | license: "BSD-2-Clause" 5 | homepage: "https://github.com/c-cube/qcheck/" 6 | doc: ["http://c-cube.github.io/qcheck/"] 7 | synopsis: "OUnit backend for qcheck" 8 | version: "0.25" 9 | tags: [ 10 | "qcheck" 11 | "quickcheck" 12 | "ounit" 13 | ] 14 | build: [ 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 17 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 18 | ] 19 | depends: [ 20 | "dune" { >= "2.8.0" } 21 | "base-unix" 22 | "qcheck-core" { = version } 23 | "ounit2" 24 | "odoc" {with-doc} 25 | "ocaml" {>= "4.08.0"} 26 | ] 27 | dev-repo: "git+https://github.com/c-cube/qcheck.git" 28 | x-maintenance-intent: ["(latest)"] 29 | bug-reports: "https://github.com/c-cube/qcheck/issues" 30 | -------------------------------------------------------------------------------- /qcheck.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "simon.cruanes.2007@m4x.org" 3 | author: [ "the qcheck contributors" ] 4 | synopsis: "Compatibility package for qcheck" 5 | homepage: "https://github.com/c-cube/qcheck/" 6 | license: "BSD-2-Clause" 7 | doc: ["http://c-cube.github.io/qcheck/"] 8 | version: "0.25" 9 | tags: [ 10 | "test" 11 | "property" 12 | "quickcheck" 13 | ] 14 | build: [ 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 17 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 18 | ] 19 | depends: [ 20 | "dune" { >= "2.8.0" } 21 | "base-unix" 22 | "qcheck-core" { = version } 23 | "qcheck-ounit" { = version } 24 | "alcotest" {with-test & >= "1.2.0"} 25 | "odoc" {with-doc} 26 | "ocaml" {>= "4.08.0"} 27 | ] 28 | dev-repo: "git+https://github.com/c-cube/qcheck.git" 29 | x-maintenance-intent: ["(latest)"] 30 | bug-reports: "https://github.com/c-cube/qcheck/issues" 31 | conflicts: [ 32 | "ounit" { < "2.0" } 33 | ] 34 | -------------------------------------------------------------------------------- /src/QCheck_runner.ml: -------------------------------------------------------------------------------- 1 | 2 | include QCheck_base_runner 3 | include QCheck_ounit 4 | -------------------------------------------------------------------------------- /src/alcotest/QCheck_alcotest.ml: -------------------------------------------------------------------------------- 1 | 2 | module Q = QCheck2 3 | module T = QCheck2.Test 4 | module Raw = QCheck_base_runner.Raw 5 | 6 | let seed_ = lazy ( 7 | let s = 8 | try int_of_string @@ Sys.getenv "QCHECK_SEED" 9 | with _ -> 10 | Random.self_init(); 11 | Random.int 1_000_000_000 12 | in 13 | Printf.printf "qcheck random seed: %d\n%!" s; 14 | s 15 | ) 16 | 17 | let default_rand () = 18 | (* random seed, for repeatability of tests *) 19 | Random.State.make [| Lazy.force seed_ |] 20 | 21 | let verbose_ = lazy ( 22 | match Sys.getenv "QCHECK_VERBOSE" with 23 | | "1" | "true" -> true 24 | | _ -> false 25 | | exception Not_found -> false 26 | ) 27 | 28 | let long_ = lazy ( 29 | match Sys.getenv "QCHECK_LONG" with 30 | | "1" | "true" -> true 31 | | _ -> false 32 | | exception Not_found -> false 33 | ) 34 | 35 | let to_alcotest 36 | ?(colors=false) ?(verbose=Lazy.force verbose_) ?(long=Lazy.force long_) 37 | ?(debug_shrink = None) ?debug_shrink_list ?(speed_level = `Slow) 38 | ?(rand=default_rand()) (t:T.t) = 39 | let T.Test cell = t in 40 | let handler name cell r = 41 | match r, debug_shrink with 42 | | QCheck2.Test.Shrunk (step, x), Some out -> 43 | let go = match debug_shrink_list with 44 | | None -> true 45 | | Some test_list -> List.mem name test_list in 46 | if not go then () 47 | else 48 | QCheck_base_runner.debug_shrinking_choices 49 | ~colors ~out ~name cell ~step x 50 | | _ -> 51 | () 52 | in 53 | let print = Raw.print_std in 54 | let name = T.get_name cell in 55 | let run () = 56 | let call = Raw.callback ~colors ~verbose ~print_res:true ~print in 57 | T.check_cell_exn ~long ~call ~handler ~rand cell 58 | in 59 | ((name, speed_level, run) : unit Alcotest.test_case) 60 | -------------------------------------------------------------------------------- /src/alcotest/QCheck_alcotest.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Alcotest backend for QCheck} 3 | 4 | We use environment variables for controlling QCheck here, since alcotest 5 | doesn't seem to provide a lot of flexibility. 6 | 7 | - [QCHECK_VERBOSE] if "1" or "true", will make tests verbose 8 | - [QCHECK_SEED] if an integer, will fix the seed 9 | - [QCHECK_LONG] is present, will trigger long tests 10 | 11 | @since 0.9 12 | *) 13 | 14 | val to_alcotest : 15 | ?colors:bool -> ?verbose:bool -> ?long:bool -> 16 | ?debug_shrink:(out_channel option) -> 17 | ?debug_shrink_list:(string list) -> 18 | ?speed_level:Alcotest.speed_level -> ?rand:Random.State.t -> 19 | QCheck2.Test.t -> unit Alcotest.test_case 20 | (** Convert a qcheck test into an alcotest test. 21 | 22 | The optional [speed_level] is [`Slow] by default, meaning Alcotest can skip 23 | such a test when the [-q] flag is passed. Passing [`Quick] instead means the 24 | test is always run. 25 | 26 | In addition to [speed_level] and the environment variables mentioned above, 27 | you can control the behavior of QCheck tests using optional parameters that 28 | behave in the same way as the parameters of {!QCheck_base_runner.run_tests}. 29 | 30 | @since 0.9 31 | @since 0.9 parameters [verbose], [long], [rand] 32 | @since 0.19 parameters [colors], [debug_shrink], [debug_shrink_list] 33 | @since 0.24 parameter [speed_level] 34 | *) 35 | -------------------------------------------------------------------------------- /src/alcotest/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name qcheck_alcotest) 4 | (public_name qcheck-alcotest) 5 | (wrapped false) 6 | (libraries unix qcheck-core qcheck-core.runner alcotest) 7 | (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) 8 | ) 9 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name qcheck_core) 4 | (public_name qcheck-core) 5 | (wrapped false) 6 | (libraries unix) 7 | (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) 8 | ) 9 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name qcheck) 3 | (public_name qcheck) 4 | (wrapped false) 5 | (modules QCheck_runner) 6 | (synopsis "compatibility library for qcheck") 7 | (libraries qcheck-core qcheck-core.runner qcheck-ounit)) 8 | -------------------------------------------------------------------------------- /src/ounit/QCheck_ounit.ml: -------------------------------------------------------------------------------- 1 | 2 | open OUnit 3 | open QCheck_base_runner 4 | 5 | let ps = Printf.printf "%s" 6 | let va = Printf.sprintf 7 | let pf = Printf.printf 8 | 9 | let not_success = function RSuccess _ -> false | _ -> true 10 | 11 | let result_path = function 12 | | RSuccess path 13 | | RError (path, _) 14 | | RFailure (path, _) 15 | | RSkip (path, _) 16 | | RTodo (path, _) -> path 17 | 18 | let result_msg = function 19 | | RSuccess _ -> "Success" 20 | | RError (_, msg) 21 | | RFailure (_, msg) 22 | | RSkip (_, msg) 23 | | RTodo (_, msg) -> msg 24 | 25 | let result_flavour = function 26 | | RError _ -> `Red, "Error" 27 | | RFailure _ -> `Red, "Failure" 28 | | RSuccess _ -> `Green, "Success" 29 | | RSkip _ -> `Blue, "Skip" 30 | | RTodo _ -> `Yellow, "Todo" 31 | 32 | let string_of_path path = 33 | let path = List.filter (function Label _ -> true | _ -> false) path in 34 | String.concat ">" (List.rev_map string_of_node path) 35 | 36 | let separator1 = "\027[K" ^ (String.make 79 '\\') 37 | let separator2 = String.make 79 '/' 38 | 39 | let print_result_list ~colors = 40 | List.iter (fun result -> 41 | let c, res = result_flavour result in 42 | pf "%s\n%a: %s\n\n%s\n%s\n" 43 | separator1 (Color.pp_str_c ~colors c) res 44 | (string_of_path (result_path result)) 45 | (result_msg result) separator2) 46 | 47 | let conf_seed = OUnit2.Conf.make_int "seed" ~-1 "set random seed" 48 | let conf_verbose = OUnit2.Conf.make_bool "qcheck_verbose" true "enable verbose QCheck tests" 49 | let conf_long = OUnit2.Conf.make_bool "qcheck_long" false "enable long QCheck tests" 50 | 51 | let default_rand () = 52 | (* random seed, for repeatability of tests *) 53 | Random.State.make [| 89809344; 994326685; 290180182 |] 54 | 55 | let to_ounit2_test ?(rand =default_rand()) (QCheck2.Test.Test cell) = 56 | let module T = QCheck2.Test in 57 | let name = T.get_name cell in 58 | let open OUnit2 in 59 | name >: test_case ~length:OUnitTest.Long (fun ctxt -> 60 | let rand = match conf_seed ctxt with 61 | | -1 -> 62 | Random.State.copy rand 63 | | s -> 64 | (* user provided random seed *) 65 | Random.State.make [| s |] 66 | in 67 | let verbose = conf_verbose ctxt in 68 | let long = conf_long ctxt in 69 | let print = { 70 | Raw. 71 | info = (fun fmt -> logf ctxt `Info fmt); 72 | fail = (fun fmt -> Printf.ksprintf assert_failure fmt); 73 | err = (fun fmt -> logf ctxt `Error fmt); 74 | } in 75 | T.check_cell_exn cell 76 | ~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print)) 77 | 78 | let to_ounit2_test_list ?rand lst = 79 | List.rev (List.rev_map (to_ounit2_test ?rand) lst) 80 | 81 | (* to convert a test to a [OUnit.test], we register a callback that will 82 | possibly print errors and counter-examples *) 83 | let to_ounit_test_cell ?(verbose=verbose()) ?(long=long_tests()) 84 | ?(rand=random_state()) cell = 85 | let module T = QCheck2.Test in 86 | let name = T.get_name cell in 87 | let run () = 88 | try 89 | T.check_cell_exn cell ~long ~rand 90 | ~call:(Raw.callback ~colors:false ~verbose ~print_res:verbose ~print:Raw.print_std); 91 | true 92 | with T.Test_fail _ -> 93 | false 94 | in 95 | name >:: (fun () -> assert_bool name (run ())) 96 | 97 | let to_ounit_test ?verbose ?long ?rand (QCheck2.Test.Test c) = 98 | to_ounit_test_cell ?verbose ?long ?rand c 99 | 100 | let (>:::) name l = 101 | name >::: (List.map (fun t -> to_ounit_test t) l) 102 | 103 | (* Function which runs the given function and returns the running time 104 | of the function, and the original result in a tuple *) 105 | let time_fun f x y = 106 | let begin_time = Unix.gettimeofday () in 107 | let res = f x y in (* evaluate this first *) 108 | Unix.gettimeofday () -. begin_time, res 109 | 110 | let run ?(argv=Sys.argv) test = 111 | let cli_args = Raw.parse_cli ~full_options:true argv in 112 | let colors = cli_args.Raw.cli_colors in 113 | (* print in colors *) 114 | let pp_color = Color.pp_str_c ~bold:true ~colors in 115 | let _counter = ref (0,0,0) in (* Success, Failure, Other *) 116 | let total_tests = test_case_count test in 117 | (* list of (test, execution time) *) 118 | let exec_times = ref [] in 119 | let update = function 120 | | RSuccess _ -> let (s,f,o) = !_counter in _counter := (succ s,f,o) 121 | | RFailure _ -> let (s,f,o) = !_counter in _counter := (s,succ f,o) 122 | | _ -> let (s,f,o) = !_counter in _counter := (s,f, succ o) 123 | in 124 | (* time each test *) 125 | let start = ref 0. and stop = ref 0. in 126 | (* display test as it starts and ends *) 127 | let display_test ?(ended=false) p = 128 | let (s,f,o) = !_counter in 129 | let cartouche = va " [%d%s%s / %d] " s 130 | (if f=0 then "" else va "+%d" f) 131 | (if o=0 then "" else va " %d!" o) total_tests 132 | and path = string_of_path p in 133 | let end_marker = 134 | if cli_args.Raw.cli_print_list then ( 135 | (* print a single line *) 136 | if ended then va " (after %.2fs)\n" (!stop -. !start) else "\n" 137 | ) else ( 138 | ps Color.reset_line; 139 | if ended then " *" else "" 140 | ) 141 | in 142 | let line = cartouche ^ path ^ end_marker in 143 | let remaining = 79 - String.length line in 144 | let cover = if remaining > 0 && not cli_args.Raw.cli_print_list 145 | then String.make remaining ' ' else "" in 146 | pf "%s%s%!" line cover; 147 | in 148 | let hdl_event = function 149 | | EStart p -> 150 | start := Unix.gettimeofday(); 151 | display_test p 152 | | EEnd p -> 153 | stop := Unix.gettimeofday(); 154 | display_test p ~ended:true; 155 | let exec_time = !stop -. !start in 156 | exec_times := (p, exec_time) :: !exec_times 157 | | EResult result -> update result 158 | in 159 | ps "Running tests..."; 160 | let running_time, results = time_fun perform_test hdl_event test in 161 | let (_s, f, o) = !_counter in 162 | let failures = List.filter not_success results in 163 | (* assert (List.length failures = f);*) 164 | ps Color.reset_line; 165 | print_result_list ~colors failures; 166 | assert (List.length results = total_tests); 167 | pf "Ran: %d tests in: %.2f seconds.%s\n" 168 | total_tests running_time (String.make 40 ' '); 169 | (* XXX: suboptimal, but should work fine *) 170 | if cli_args.Raw.cli_slow_test > 0 then ( 171 | pf "Display the %d slowest tests:\n" cli_args.Raw.cli_slow_test; 172 | let l = !exec_times in 173 | let l = List.sort (fun (_,t1)(_,t2) -> compare t2 t1) l in 174 | List.iteri 175 | (fun i (p,t) -> 176 | if i 0 then ( 184 | pf "%a SOME TESTS ARE NEITHER SUCCESSES NOR FAILURES!\n" 185 | (pp_color `Yellow) "WARNING!"; 186 | ); 187 | if failures <> [] then ( 188 | pf "%a\n" (pp_color `Red) "FAILURE"; 189 | ); 190 | (* create a meaningful return code for the process running the tests *) 191 | match f, o with 192 | | 0, 0 -> 0 193 | | _ -> 1 194 | 195 | (* TAP-compatible test runner, in case we want to use a test harness *) 196 | 197 | let run_tap test = 198 | let test_number = ref 0 in 199 | let handle_event = function 200 | | EStart _ | EEnd _ -> incr test_number 201 | | EResult (RSuccess p) -> 202 | pf "ok %d - %s\n%!" !test_number (string_of_path p) 203 | | EResult (RFailure (p,m)) -> 204 | pf "not ok %d - %s # %s\n%!" !test_number (string_of_path p) m 205 | | EResult (RError (p,m)) -> 206 | pf "not ok %d - %s # ERROR:%s\n%!" !test_number (string_of_path p) m 207 | | EResult (RSkip (p,m)) -> 208 | pf "not ok %d - %s # skip %s\n%!" !test_number (string_of_path p) m 209 | | EResult (RTodo (p,m)) -> 210 | pf "not ok %d - %s # todo %s\n%!" !test_number (string_of_path p) m 211 | in 212 | let total_tests = test_case_count test in 213 | pf "TAP version 13\n1..%d\n" total_tests; 214 | perform_test handle_event test 215 | -------------------------------------------------------------------------------- /src/ounit/QCheck_ounit.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Conversion of tests to OUnit Tests} 3 | 4 | @since 0.9 5 | *) 6 | 7 | val to_ounit_test : 8 | ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> 9 | QCheck2.Test.t -> OUnit.test 10 | (** [to_ounit_test ~rand t] wraps [t] into a OUnit test 11 | @param verbose used to print information on stdout (default: [verbose()]) 12 | @param rand the random generator to use (default: [random_state ()]) *) 13 | 14 | val to_ounit_test_cell : 15 | ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> 16 | _ QCheck2.Test.cell -> OUnit.test 17 | (** Same as {!to_ounit_test} but with a polymorphic test cell *) 18 | 19 | val (>:::) : string -> QCheck2.Test.t list -> OUnit.test 20 | (** Same as [OUnit.(>:::)] but with a list of QCheck2 tests *) 21 | 22 | val to_ounit2_test : ?rand:Random.State.t -> QCheck2.Test.t -> OUnit2.test 23 | (** [to_ounit2_test ?rand t] wraps [t] into a OUnit2 test 24 | @param rand the random generator to use (default: a static seed for reproducibility), 25 | can be overridden with "-seed" on the command-line 26 | *) 27 | 28 | val to_ounit2_test_list : ?rand:Random.State.t -> QCheck2.Test.t list -> OUnit2.test list 29 | (** [to_ounit2_test_list ?rand t] like [to_ounit2_test] but for a list of tests *) 30 | 31 | (** {2 OUnit runners} 32 | 33 | QCheck provides some custom runners for OUnit tests. 34 | 35 | - {!run} is used by {{: https://github.com/vincent-hugot/qtest} qtest}. 36 | - {!run_tap} should be compatible with {{: https://en.wikipedia.org/wiki/Test_Anything_Protocol} TAP}. 37 | 38 | Note that {!OUnit.run_test_tt} or {!OUnit.run_test_tt_main} can be used as well, 39 | in particular when QCheck tests are mixed with normal unit tests. 40 | 41 | For OUnit2 you can use {!OUnit2.run_test_tt_main}. 42 | *) 43 | 44 | 45 | val run : ?argv:string array -> OUnit.test -> int 46 | (** [run test] runs the test, and returns an error code that is [0] 47 | if all tests passed, [1] otherwise. 48 | This is the default runner used by the comment-to-test generator. 49 | 50 | @param argv the command line arguments to parse parameters from (default [Sys.argv]) 51 | @raise Arg.Bad in case [argv] contains unknown arguments 52 | @raise Arg.Help in case [argv] contains "--help" 53 | 54 | This test runner displays execution in a compact way, making it good 55 | for suites that have lots of tests. 56 | 57 | Output example: 58 | {v 59 | random seed: 101121210 60 | random seed: 101121210 61 | \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 62 | Error: tests>error_raise_exn 63 | 64 | test `error_raise_exn` raised exception `QCheck_ounit_test.Error` 65 | on `0 (after 62 shrink steps)` 66 | Raised at file "example/QCheck_ounit_test.ml", line 19, characters 20-25 67 | Called from file "src/QCheck.ml", line 846, characters 13-33 68 | 69 | /////////////////////////////////////////////////////////////////////////////// 70 | \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 71 | Failure: tests>fail_sort_id 72 | 73 | fail_sort_id 74 | /////////////////////////////////////////////////////////////////////////////// 75 | Ran: 4 tests in: 0.74 seconds. 76 | WARNING! SOME TESTS ARE NEITHER SUCCESSES NOR FAILURES! 77 | v} 78 | *) 79 | 80 | val run_tap : OUnit.test -> OUnit.test_results 81 | (** TAP-compatible test runner, in case we want to use a test harness. 82 | It prints one line per test. *) 83 | 84 | -------------------------------------------------------------------------------- /src/ounit/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name qcheck_ounit) 4 | (public_name qcheck-ounit) 5 | (wrapped false) 6 | (libraries unix qcheck-core qcheck-core.runner ounit2) 7 | (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) 8 | ) 9 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/QCheck_generators.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (** This module contains all generators from QCheck used to 4 | derive a type declaration *) 5 | 6 | (** {2 Version} *) 7 | 8 | type version = [`QCheck | `QCheck2] 9 | 10 | let to_module : version -> string = function 11 | | `QCheck -> "QCheck" 12 | | `QCheck2 -> "QCheck2" 13 | 14 | let with_prefix loc version prefix x = 15 | let (module A) = Ast_builder.make loc in 16 | A.Located.mk @@ Ldot (Ldot (Lident (to_module version), prefix), x) 17 | |> A.pexp_ident 18 | 19 | let with_prefix_gen loc version x = with_prefix loc version "Gen" x 20 | 21 | let with_prefix_obs loc version x = with_prefix loc version "Observable" x 22 | 23 | let apply1 loc f a = [%expr [%e f] [%e a]] 24 | 25 | let apply2 loc f a b = [%expr [%e f] [%e a] [%e b]] 26 | 27 | let apply3 loc f a b c = [%expr [%e f] [%e a] [%e b] [%e c]] 28 | 29 | let apply4 loc f a b c d = [%expr [%e f] [%e a] [%e b] [%e c] [%e d]] 30 | 31 | (** {2 Type} *) 32 | 33 | let ty version = Ldot (Ldot (Lident (to_module version), "Gen"), "t") 34 | 35 | (** {2 Primitive generators} *) 36 | 37 | let unit loc version = with_prefix_gen loc version "unit" 38 | 39 | let int loc version = with_prefix_gen loc version "int" 40 | 41 | let string loc version = with_prefix_gen loc version "string" 42 | 43 | let char loc version = with_prefix_gen loc version "char" 44 | 45 | let bool loc version = with_prefix_gen loc version "bool" 46 | 47 | let float loc version = with_prefix_gen loc version "float" 48 | 49 | let int32 loc version = with_prefix_gen loc version "ui32" 50 | 51 | let int64 loc version = with_prefix_gen loc version "ui64" 52 | 53 | let option ~loc ~version e = 54 | let gen = with_prefix_gen loc version "option" in 55 | apply1 loc gen e 56 | 57 | let list ~loc ~version e = 58 | let gen = with_prefix_gen loc version "list" in 59 | apply1 loc gen e 60 | 61 | let array ~loc ~version e = 62 | let gen = with_prefix_gen loc version "array" in 63 | apply1 loc gen e 64 | 65 | (** {2 Generator combinators} *) 66 | 67 | let pure ~loc ~version e = 68 | let gen = with_prefix_gen loc version "pure" in 69 | apply1 loc gen e 70 | 71 | let frequency ~loc ~version l = 72 | match l with 73 | | [%expr [([%e? _], [%e? x])]] -> x 74 | | _ -> 75 | let gen = with_prefix_gen loc version "frequency" in 76 | apply1 loc gen l 77 | 78 | let map ~loc ~version pat expr gen = 79 | let f = with_prefix_gen loc version "map" in 80 | apply2 loc f [%expr fun [%p pat] -> [%e expr]] gen 81 | 82 | let pair ~loc ~version a b = 83 | let gen = with_prefix_gen loc version "pair" in 84 | apply2 loc gen a b 85 | 86 | let triple ~loc ~version a b c = 87 | let gen = with_prefix_gen loc version "triple" in 88 | apply3 loc gen a b c 89 | 90 | let quad ~loc ~version a b c d = 91 | let gen = with_prefix_gen loc version "quad" in 92 | apply4 loc gen a b c d 93 | 94 | let sized ~loc ~version e = 95 | let gen = with_prefix_gen loc version "sized" in 96 | apply1 loc gen e 97 | 98 | let fix ~loc ~version e = 99 | let gen = with_prefix_gen loc version "fix" in 100 | apply1 loc gen e 101 | 102 | (** Observable generators *) 103 | module Observable = struct 104 | (** {2 Primitive generators} *) 105 | let unit loc version = with_prefix_obs loc version "unit" 106 | 107 | let int loc version = with_prefix_obs loc version "int" 108 | 109 | let string loc version = with_prefix_obs loc version "string" 110 | 111 | let char loc version = with_prefix_obs loc version "char" 112 | 113 | let bool loc version = with_prefix_obs loc version "bool" 114 | 115 | let float loc version = with_prefix_obs loc version "float" 116 | 117 | let int32 loc version = with_prefix_obs loc version "int32" 118 | 119 | let int64 loc version = with_prefix_obs loc version "int64" 120 | 121 | let option ~loc ~version e = 122 | let obs = with_prefix_obs loc version "option" in 123 | apply1 loc obs e 124 | 125 | let list ~loc ~version e = 126 | let obs = with_prefix_obs loc version "list" in 127 | apply1 loc obs e 128 | 129 | let array ~loc ~version e = 130 | let obs = with_prefix_obs loc version "array" in 131 | apply1 loc obs e 132 | 133 | (** {2 Observable combinators} *) 134 | let pair ~loc ~version a b = 135 | let obs = with_prefix_obs loc version "pair" in 136 | apply2 loc obs a b 137 | 138 | let triple ~loc ~version a b c = 139 | let obs = with_prefix_obs loc version "triple" in 140 | apply3 loc obs a b c 141 | 142 | let quad ~loc ~version a b c d = 143 | let obs = with_prefix_obs loc version "quad" in 144 | apply4 loc obs a b c d 145 | 146 | let fun_nary ~loc ~version left right gen = 147 | match version with 148 | | `QCheck -> 149 | let arb = [%expr QCheck.make [%e gen]] in 150 | [%expr QCheck.fun_nary QCheck.Tuple.([%e left] @-> [%e right]) [%e arb] |> QCheck.gen] 151 | | `QCheck2 -> 152 | [%expr QCheck2.fun_nary QCheck2.Tuple.([%e left] @-> [%e right]) [%e gen]] 153 | end 154 | 155 | module Make (Version : sig val version : version end) = struct 156 | let version = Version.version 157 | let ty = ty version 158 | let unit loc = unit loc version 159 | let int loc = int loc version 160 | let string loc = string loc version 161 | let char loc = char loc version 162 | let bool loc = bool loc version 163 | let float loc = float loc version 164 | let int32 loc = int32 loc version 165 | let int64 loc = int64 loc version 166 | let option ~loc = option ~loc ~version 167 | let list ~loc = list ~loc ~version 168 | let array ~loc = array ~loc ~version 169 | let pure ~loc x = pure ~loc ~version x 170 | let frequency ~loc l = frequency ~loc ~version l 171 | let map ~loc pat expr gen = map ~loc ~version pat expr gen 172 | let pair ~loc a b = pair ~loc ~version a b 173 | let triple ~loc a b c = triple ~loc ~version a b c 174 | let quad ~loc a b c d = quad ~loc ~version a b c d 175 | let sized ~loc e = sized ~loc ~version e 176 | let fix ~loc e = fix ~loc ~version e 177 | module Observable = struct 178 | let unit loc = Observable.unit loc version 179 | let int loc = Observable.int loc version 180 | let string loc = Observable.string loc version 181 | let char loc = Observable.char loc version 182 | let bool loc = Observable.bool loc version 183 | let float loc = Observable.float loc version 184 | let int32 loc = Observable.int32 loc version 185 | let int64 loc = Observable.int64 loc version 186 | let option ~loc e = Observable.option ~loc ~version e 187 | let list ~loc e = Observable.list ~loc ~version e 188 | let array ~loc e = Observable.array ~loc ~version e 189 | let pair ~loc a b = Observable.pair ~loc ~version a b 190 | let triple ~loc a b c = Observable.triple ~loc ~version a b c 191 | let quad ~loc a b c d = Observable.quad ~loc ~version a b c d 192 | let fun_nary ~loc left right gen = Observable.fun_nary ~loc ~version left right gen 193 | end 194 | end 195 | 196 | module QCheck = Make (struct let version = `QCheck end) 197 | module QCheck2 = Make (struct let version = `QCheck2 end) 198 | module type S = module type of QCheck 199 | 200 | let make version = (module Make (struct let version = version end) : S) 201 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/README.md: -------------------------------------------------------------------------------- 1 | # ppx_deriving_qcheck 2 | 3 | ## Generator 4 | Derive `QCheck.Gen.t` from a type declaration 5 | 6 | ```ocaml 7 | type tree = Leaf of int | Node of tree * tree 8 | [@@deriving qcheck] 9 | 10 | let rec rev tree = match tree with 11 | | Leaf _ -> tree 12 | | Node (left, right) -> Node (rev right, rev left) 13 | 14 | let test = 15 | QCheck.Test.make 16 | ~name:"tree -> rev (rev tree) = tree" 17 | (QCheck.make gen_tree) 18 | (fun tree -> rev (rev tree) = tree) 19 | ``` 20 | 21 | For `type tree` we derive two generators: 22 | - `val gen_tree : tree Gen.t` and 23 | - `val gen_tree_sized : int -> tree Gen.t` 24 | 25 | For non-recursive types the latter is however not derived. 26 | 27 | For types with the name `t` (i.e. `type t = ...`) which is a common idiom in OCaml code, 28 | the deriver omits the name from the derived generators, 29 | thus producing `val gen : t Gen.t` and optionally `val gen_sized : int -> t Gen.t`. 30 | 31 | ### Overwrite generator 32 | If you wan't to specify your own `generator` for any type you can 33 | add an attribute to the type: 34 | 35 | ```ocaml 36 | type t = (int : [@gen QCheck.Gen.(0 -- 10)]) 37 | [@@deriving qcheck] 38 | 39 | (* produces ==> *) 40 | 41 | let gen : t QCheck.Gen.t = QCheck.Gen.(0 -- 10) 42 | ``` 43 | 44 | This attribute has 2 advantages: 45 | * Use your own generator for a specific type (see above) 46 | * There is no generator available for the type 47 | ```ocaml 48 | type my_foo = 49 | | Foo of my_other_type 50 | | Bar of bool 51 | [@@deriving qcheck] 52 | ^^^^^^^^^^^^^^^^ 53 | Error: Unbound value gen_my_other_type 54 | 55 | (* Possible fix *) 56 | let gen_my_other_type = (* add your implementation here *) 57 | 58 | type my_foo = 59 | | Foo of my_other_type [@gen gen_my_other_type] 60 | | Bar of bool 61 | [@@deriving qcheck] 62 | ``` 63 | 64 | ## How to use 65 | 66 | Add to your OCaml libraries with dune 67 | ```ocaml 68 | ... 69 | (preprocess (pps ppx_deriving_qcheck))) 70 | ... 71 | ``` 72 | 73 | ## Supported types 74 | 75 | ### Primitive types 76 | 77 | * Unit 78 | ```ocaml 79 | type t = unit [@@deriving qcheck] 80 | 81 | (* ==> *) 82 | 83 | let gen = QCheck.Gen.unit 84 | ``` 85 | 86 | * Bool 87 | ```ocaml 88 | type t = bool [@@deriving qcheck] 89 | 90 | (* ==> *) 91 | 92 | let gen = QCheck.Gen.bool 93 | ``` 94 | 95 | * Integer 96 | ```ocaml 97 | type t = int [@@deriving qcheck] 98 | 99 | (* ==> *) 100 | 101 | let gen = QCheck.Gen.int 102 | ``` 103 | 104 | * Float 105 | ```ocaml 106 | type t = float [@@deriving qcheck] 107 | 108 | (* ==> *) 109 | 110 | let gen = QCheck.Gen.float 111 | ``` 112 | 113 | * String 114 | ```ocaml 115 | type t = string [@@deriving qcheck] 116 | 117 | (* ==> *) 118 | 119 | let gen = QCheck.Gen.string 120 | ``` 121 | 122 | * Char 123 | ```ocaml 124 | type t = char [@@deriving qcheck] 125 | 126 | (* ==> *) 127 | 128 | let gen = QCheck.Gen.char 129 | ``` 130 | 131 | * Option 132 | ```ocaml 133 | type 'a t = 'a option [@@deriving qcheck] 134 | 135 | (* ==> *) 136 | 137 | let gen gen_a = QCheck.Gen.option gen_a 138 | ``` 139 | 140 | * List 141 | ```ocaml 142 | type 'a t = 'a list [@@deriving qcheck] 143 | 144 | (* ==> *) 145 | 146 | let gen gen_a = QCheck.Gen.list gen_a 147 | ``` 148 | 149 | * Array 150 | ```ocaml 151 | type 'a t = 'a array [@@deriving qcheck] 152 | 153 | (* ==> *) 154 | 155 | let gen gen_a = QCheck.Gen.array gen_a 156 | ``` 157 | 158 | ### Tuples of size `n` 159 | 160 | * n = 2 161 | ```ocaml 162 | type t = int * int [@@deriving qcheck] 163 | 164 | (* ==> *) 165 | 166 | let gen = QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int 167 | ``` 168 | 169 | * n = 3 170 | ```ocaml 171 | type t = int * int * int [@@deriving qcheck] 172 | 173 | (* ==> *) 174 | 175 | let gen = QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int 176 | ``` 177 | 178 | * n = 4 179 | ```ocaml 180 | type t = int * int * int * int [@@deriving qcheck] 181 | 182 | (* ==> *) 183 | 184 | let gen = QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int 185 | ``` 186 | 187 | * n > 4, tuples are split between pairs, for instance n = 8 188 | ```ocaml 189 | type t = int * int * int * int * int * int * int * int [@@deriving qcheck] 190 | 191 | (* ==> *) 192 | 193 | let gen = 194 | QCheck.Gen.pair 195 | (QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int) 196 | (QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int) 197 | ``` 198 | 199 | ## Records 200 | ```ocaml 201 | type service = { 202 | service_name : string; 203 | port : int; 204 | protocol : string; 205 | } [@@deriving qcheck] 206 | 207 | (* ==> *) 208 | 209 | let gen_service = 210 | QCheck.Gen.map 211 | (fun (gen0, gen1, gen2) -> 212 | { service_name = gen0; port = gen1; protocol = gen2 }) 213 | (QCheck.Gen.triple QCheck.Gen.string QCheck.Gen.int QCheck.Gen.string) 214 | ``` 215 | 216 | ## Variants 217 | * Variants 218 | ```ocaml 219 | type color = Red | Blue | Green 220 | [@@deriving qcheck] 221 | 222 | (* ==> *) 223 | 224 | let gen_color = 225 | QCheck.Gen.frequency 226 | [(1, (QCheck.Gen.pure Red)); 227 | (1, (QCheck.Gen.pure Blue)); 228 | (1, (QCheck.Gen.pure Green))] 229 | ``` 230 | 231 | * Polymorphic variants 232 | ```ocaml 233 | type color = [ `Red | `Blue | `Green ] 234 | [@@deriving qcheck] 235 | 236 | (* ==> *) 237 | 238 | let gen_color = 239 | (QCheck.Gen.frequency 240 | [(1, (QCheck.Gen.pure `Red)); 241 | (1, (QCheck.Gen.pure `Blue)); 242 | (1, (QCheck.Gen.pure `Green))] : color QCheck.Gen.t) 243 | ``` 244 | 245 | ## Recursive variants 246 | * Recursive variants 247 | ```ocaml 248 | type tree = Leaf of int | Node of tree * tree 249 | [@@deriving qcheck] 250 | 251 | (* ==> *) 252 | 253 | let rec gen_tree_sized n = 254 | match n with 255 | | 0 -> QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int 256 | | n -> 257 | QCheck.Gen.frequency 258 | [(1, (QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int)); 259 | (1, 260 | (QCheck.Gen.map (fun (gen0, gen1) -> Node (gen0, gen1)) 261 | (QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))])) 262 | 263 | let gen_tree = QCheck.Gen.sized @@ gen_tree_sized 264 | ``` 265 | 266 | * Recursive polymorphic variants 267 | ```ocaml 268 | type tree = [ `Leaf of int | `Node of tree * tree ] 269 | [@@deriving qcheck] 270 | 271 | (* ==> *) 272 | 273 | let gen_tree = 274 | (QCheck.Gen.sized @@ QCheck.Gen.fix (fun self -> function 275 | | 0 -> 276 | QCheck.Gen.frequency [ 277 | ( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int); 278 | ] 279 | | n -> 280 | QCheck.Gen.frequency [ 281 | ( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int); 282 | ( 1, 283 | QCheck.Gen.map (fun gen0 -> `Node gen0) 284 | (QCheck.Gen.map 285 | (fun (gen0, gen1) -> (gen0, gen1)) 286 | (QCheck.Gen.pair (self (n / 2)) (self (n / 2))))) 287 | ]) 288 | : tree QCheck.Gen.t) 289 | ``` 290 | 291 | ## Mutual recursive types 292 | ```ocaml 293 | type tree = Node of (int * forest) 294 | and forest = Nil | Cons of (tree * forest) 295 | [@@deriving qcheck] 296 | 297 | (* ==> *) 298 | 299 | let rec gen_tree () = 300 | QCheck.Gen.frequency 301 | [(1, 302 | (QCheck.Gen.map (fun gen0 -> Node gen0) 303 | (QCheck.Gen.map (fun (gen0, gen1) -> (gen0, gen1)) 304 | (QCheck.Gen.pair QCheck.Gen.int (gen_forest ())))))] 305 | 306 | and gen_forest () = 307 | QCheck.Gen.sized @@ 308 | (QCheck.Gen.fix 309 | (fun self -> function 310 | | 0 -> QCheck.Gen.frequency [(1, (QCheck.Gen.pure Nil))] 311 | | n -> 312 | QCheck.Gen.frequency 313 | [(1, (QCheck.Gen.pure Nil)); 314 | (1, 315 | (QCheck.Gen.map (fun gen0 -> Cons gen0) 316 | (QCheck.Gen.map (fun (gen0, gen1) -> (gen0, gen1)) 317 | (QCheck.Gen.pair (gen_tree ()) (self (n / 2))))))])) 318 | 319 | let gen_tree = gen_tree () 320 | 321 | let gen_forest = gen_forest () 322 | ``` 323 | 324 | ## Unsupported types 325 | 326 | ### GADT 327 | Deriving a GADT currently produces an ill-typed generator. 328 | 329 | ### Let us know 330 | If you encounter a unsupported type (that should be), please let us know by creating 331 | an issue. 332 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/args.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (** [curry_args args body] adds parameter to [body] 4 | 5 | e.g.: 6 | curry_args [gen_a; gen_b] () => fun gen_a -> fun gen_b -> () 7 | *) 8 | let rec curry_args ~loc args body = 9 | match args with 10 | | [] -> body 11 | | x :: xs -> [%expr fun [%p x] -> [%e curry_args ~loc xs body]] 12 | 13 | (** [apply_args args body] applies parameters to [body] 14 | 15 | e.g.: 16 | apply_args [gen_a; gen_b] f => f gen_a gen_b 17 | *) 18 | let apply_args ~loc args body = 19 | let rec aux acc = function 20 | | [] -> acc 21 | | [arg] -> [%expr [%e acc] [%e arg]] 22 | | arg :: args -> aux [%expr [%e acc] [%e arg]] args 23 | in 24 | aux body args 25 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/attributes.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (** [find_first_attribute xs name] returns the first attribute found in [xs] 4 | named [name] *) 5 | let find_attribute_opt xs name = 6 | List.find_opt (fun attribute -> attribute.attr_name.txt = name) xs 7 | 8 | let get_expr_payload x = 9 | match x.attr_payload with 10 | | PStr [ { pstr_desc = Pstr_eval (e, _); _ } ] -> Some [%expr [%e e]] 11 | | _ -> None 12 | 13 | let gen ct = 14 | Option.fold ~none:None ~some:get_expr_payload 15 | @@ find_attribute_opt ct.ptyp_attributes "gen" 16 | 17 | let weight xs = 18 | Option.fold ~none:None ~some:get_expr_payload 19 | @@ find_attribute_opt xs "weight" 20 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/attributes.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | (** This file handles every attributes to be found in a core_type definition *) 3 | 4 | val gen : core_type -> expression option 5 | (** [gen loc ct] look for an attribute "gen" in [ct] 6 | 7 | example: 8 | {[ 9 | type t = 10 | | A of int 11 | | B of (int [@gen QCheck.int32]) 12 | ]} 13 | 14 | It allows the user to specify which generator he wants for a specific type. 15 | Returns the generator as an expression and returns None if no attribute 16 | is present *) 17 | 18 | val weight : attributes -> expression option 19 | (** [weight loc ct] look for an attribute "weight" in [ct] 20 | 21 | example: 22 | {[ 23 | type t = 24 | | A [@weight 5] 25 | | B [@weight 6] 26 | | C 27 | ]} 28 | It allows the user to specify the weight of a type case. *) 29 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_qcheck) 3 | (public_name ppx_deriving_qcheck) 4 | (libraries ppxlib) 5 | (preprocess (pps ppxlib.metaquot)) 6 | (ppx_runtime_libraries qcheck-core) 7 | (kind ppx_deriver)) 8 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | val derive_gens : 4 | version:[`QCheck | `QCheck2] -> 5 | loc:location -> 6 | rec_flag * type_declaration list -> 7 | structure 8 | (** [derive_gens ~version ~loc xs] creates generators for type declaration in [xs]. 9 | 10 | The generators can either be [QCheck.Gen.t] or [QCheck2.Gen.t] based on 11 | [version]. *) 12 | 13 | val derive_arbs : 14 | loc:location -> 15 | rec_flag * type_declaration list -> 16 | structure 17 | (** [derive_arbs ~loc xs] creates generators for type declaration in [xs] and 18 | use these lasts to build [QCheck.arbitrary]. *) 19 | -------------------------------------------------------------------------------- /src/ppx_deriving_qcheck/tuple.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module G = QCheck_generators 3 | module O = G.Observable 4 | 5 | (** {1 Tuple } *) 6 | 7 | (** This module implements nested tuples based on QCheck tuples generators (or observables): 8 | - [Gen.pair] 9 | - [Gen.triple] 10 | - [Gen.quad] 11 | 12 | It can be used to nest large tuples in a generator. 13 | - e.g. 14 | {[ 15 | type t = int * int * int 16 | ]} 17 | 18 | Lets say QCheck does not have combinator to generate a triple. One has to write: 19 | 20 | {[ 21 | let gen = QCheck.Gen.(map (fun ((x, y), z) -> (x, y, z) (pair (pair int int) int)) 22 | ]} 23 | 24 | We copy this nesting mechanism with this module. 25 | *) 26 | 27 | type 'a t = 28 | | Pair of 'a t * 'a t 29 | | Triple of 'a * 'a * 'a 30 | | Quad of 'a * 'a * 'a * 'a 31 | | Elem of 'a 32 | 33 | (** [from_list l] builds an {!'a t}, if len of [l] is greater than 4, the list 34 | is split into a [Pair] of generators. *) 35 | let rec from_list = function 36 | | [ a; b; c; d ] -> Quad (a, b, c, d) 37 | | [ a; b; c ] -> Triple (a, b, c) 38 | | [ a; b ] -> Pair (Elem a, Elem b) 39 | | [ a ] -> Elem a 40 | | l -> 41 | let n = List.length l / 2 in 42 | let i = ref 0 in 43 | let l1 = 44 | List.filter 45 | (fun _ -> 46 | let x = !i in 47 | i := x + 1; 48 | x < n) 49 | l 50 | in 51 | i := 0; 52 | let l2 = 53 | List.filter 54 | (fun _ -> 55 | let x = !i in 56 | i := x + 1; 57 | x >= n) 58 | l 59 | in 60 | Pair (from_list l1, from_list l2) 61 | 62 | let rec to_list = function 63 | | Quad (a, b, c, d) -> [ a; b; c; d ] 64 | | Triple (a, b, c) -> [ a; b; c ] 65 | | Pair (a, b) -> to_list a @ to_list b 66 | | Elem a -> [ a ] 67 | 68 | (** [to_expr ~loc t] creates a tuple expression based on [t]. 69 | [t] is transformed to a list, and each element from the list becomes 70 | a variable referencing a generator. 71 | 72 | - e.g. 73 | to_expr (Pair (_, _)) => (gen0, gen1) 74 | *) 75 | let to_expr ~loc t = 76 | let l = to_list t in 77 | let (module A) = Ast_builder.make loc in 78 | List.mapi 79 | (fun i _ -> 80 | let s = Printf.sprintf "gen%d" i in 81 | A.evar s) 82 | l 83 | |> A.pexp_tuple 84 | 85 | (** [nest pair triple quad t] creates a generator expression for [t] using 86 | 87 | - [pair] to combine Pair (_, _) 88 | - [triple] to combine Triple (_, _, ) 89 | - [quad] to combine Quad (_, _, _, _) 90 | *) 91 | let rec nest ~pair ~triple ~quad = function 92 | | Quad (a, b, c, d) -> quad a b c d 93 | | Triple (a, b, c) -> triple a b c 94 | | Pair (a, b) -> 95 | pair 96 | (nest ~pair ~triple ~quad a) 97 | (nest ~pair ~triple ~quad b) 98 | | Elem a -> a 99 | 100 | (** [to_gen t] creates a Gen.t with generators' combinators *) 101 | let to_gen ~loc ~version t = 102 | nest 103 | ~pair:(G.pair ~loc ~version) 104 | ~triple:(G.triple ~loc ~version) 105 | ~quad:(G.quad ~loc ~version) t 106 | 107 | (** [to_obs t] creates a Obs.t with obsersvables' combinators *) 108 | let to_obs ~loc ~version t = 109 | nest 110 | ~pair:(O.pair ~loc ~version) 111 | ~triple:(O.triple ~loc ~version) 112 | ~quad:(O.quad ~loc ~version) t 113 | 114 | let to_pat ~loc t = 115 | let fresh_id = 116 | let id = ref 0 in 117 | fun () -> 118 | let x = !id in 119 | let () = id := x + 1 in 120 | Printf.sprintf "gen%d" x 121 | in 122 | let (module A) = Ast_builder.make loc in 123 | let rec aux = function 124 | | Quad (_, _, _, _) -> 125 | let a = A.pvar @@ fresh_id () in 126 | let b = A.pvar @@ fresh_id () in 127 | let c = A.pvar @@ fresh_id () in 128 | let d = A.pvar @@ fresh_id () in 129 | [%pat? [%p a], [%p b], [%p c], [%p d]] 130 | | Triple (_, _, _) -> 131 | let a = A.pvar @@ fresh_id () in 132 | let b = A.pvar @@ fresh_id () in 133 | let c = A.pvar @@ fresh_id () in 134 | [%pat? [%p a], [%p b], [%p c]] 135 | | Pair (a, b) -> 136 | let a = aux a in 137 | let b = aux b in 138 | [%pat? [%p a], [%p b]] 139 | | Elem _ -> A.pvar @@ fresh_id () 140 | in 141 | aux t 142 | -------------------------------------------------------------------------------- /src/runner/QCheck_base_runner.ml: -------------------------------------------------------------------------------- 1 | (* 2 | QCheck: Random testing for OCaml 3 | copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard 4 | all rights reserved. 5 | *) 6 | 7 | module Color = struct 8 | let fpf = Printf.fprintf 9 | type color = 10 | [ `Red 11 | | `Yellow 12 | | `Green 13 | | `Blue 14 | | `Normal 15 | | `Cyan 16 | ] 17 | 18 | let int_of_color_ : color -> int = function 19 | | `Normal -> 0 20 | | `Red -> 1 21 | | `Green -> 2 22 | | `Yellow -> 3 23 | | `Blue -> 4 24 | | `Cyan -> 6 25 | 26 | (* same as [pp], but in color [c] *) 27 | let in_color c pp out x = 28 | let n = int_of_color_ c in 29 | fpf out "\x1b[3%dm" n; 30 | pp out x; 31 | fpf out "\x1b[0m" 32 | 33 | (* same as [pp], but in bold color [c] *) 34 | let in_bold_color c pp out x = 35 | let n = int_of_color_ c in 36 | fpf out "\x1b[3%d;1m" n; 37 | pp out x; 38 | fpf out "\x1b[0m" 39 | 40 | let reset_line = "\x1b[2K\r" 41 | 42 | let pp_str_c ?(bold=true) ~colors c out s = 43 | if colors then 44 | if bold then in_bold_color c output_string out s 45 | else in_color c output_string out s 46 | else output_string out s 47 | end 48 | 49 | let seed = ref ~-1 50 | let st = ref None 51 | 52 | let set_seed_ ~colors s = 53 | seed := s; 54 | if colors then Printf.printf "%srandom seed: %d\n%!" Color.reset_line s 55 | else Printf.printf "random seed: %d\n%!" s; 56 | let state = Random.State.make [| s |] in 57 | st := Some state; 58 | state 59 | 60 | (* time of last printed message. Useful for rate limiting in verbose mode *) 61 | let last_msg = ref 0. 62 | 63 | let time_between_msg = 64 | let env_var = "QCHECK_MSG_INTERVAL" in 65 | let default_interval = 0.1 in 66 | let interval = match Sys.getenv_opt env_var with 67 | | None -> default_interval 68 | | Some f -> 69 | match float_of_string_opt f with 70 | | None -> invalid_arg (env_var ^ " must be a float") 71 | | Some i -> i in 72 | if interval < 0. then invalid_arg (env_var ^ " must be >= 0 but value is " ^ string_of_float interval); 73 | ref interval 74 | 75 | let get_time_between_msg () = !time_between_msg 76 | 77 | let set_time_between_msg f = time_between_msg := f 78 | 79 | let set_seed s = ignore (set_seed_ ~colors:false s) 80 | 81 | let setup_random_state_ ~colors () = 82 | let s = if !seed = ~-1 then ( 83 | Random.self_init (); (* make new, truly random seed *) 84 | Random.int (1 lsl 29); 85 | ) else !seed in 86 | set_seed_ ~colors s 87 | 88 | (* initialize random generator from seed (if any) *) 89 | let random_state_ ~colors () = match !st with 90 | | Some st -> st 91 | | None -> setup_random_state_ ~colors () 92 | 93 | let random_state() = random_state_ ~colors:false () 94 | 95 | let verbose, set_verbose = 96 | let r = ref false in 97 | (fun () -> !r), (fun b -> r := b) 98 | 99 | let long_tests, set_long_tests = 100 | let r = ref false in 101 | (fun () -> !r), (fun b -> r := b) 102 | 103 | let debug_shrink, set_debug_shrink = 104 | let r = ref None in 105 | (fun () -> !r), (fun s -> r := Some (open_out s)) 106 | 107 | let debug_shrink_list, set_debug_shrink_list = 108 | let r = ref [] in 109 | (fun () -> !r), (fun b -> r := b :: !r) 110 | 111 | module Raw = struct 112 | type ('b,'c) printer = { 113 | info: 'a. ('a,'b,'c,unit) format4 -> 'a; 114 | fail: 'a. ('a,'b,'c,unit) format4 -> 'a; 115 | err: 'a. ('a,'b,'c,unit) format4 -> 'a; 116 | } 117 | 118 | type cli_args = { 119 | cli_verbose : bool; 120 | cli_long_tests : bool; 121 | cli_print_list : bool; 122 | cli_rand : Random.State.t; 123 | cli_slow_test : int; (* how many slow tests to display? *) 124 | cli_colors: bool; 125 | cli_debug_shrink : out_channel option; 126 | cli_debug_shrink_list : string list; 127 | } 128 | 129 | (* main callback for individual tests 130 | @param verbose if true, print statistics and details 131 | @param print_res if true, print the result on [out] *) 132 | let callback ~colors ~verbose ~print_res ~print name cell result = 133 | let module R = QCheck2.TestResult in 134 | let module T = QCheck2.Test in 135 | let reset_line = if colors then Color.reset_line else "\n" in 136 | if verbose then ( 137 | print.info "%slaw %s: %d relevant cases (%d total)\n" 138 | reset_line name (R.get_count result) (R.get_count_gen result); 139 | begin match QCheck2.TestResult.collect result with 140 | | None -> () 141 | | Some tbl -> 142 | print_string (QCheck2.Test.print_collect tbl) 143 | end; 144 | ); 145 | if print_res then ( 146 | (* even if [not verbose], print errors *) 147 | match R.get_state result with 148 | | R.Success -> 149 | if not (T.get_positive cell) 150 | then 151 | print.fail "%snegative test '%s' succeeded unexpectedly\n" reset_line name; 152 | | R.Failed {instances=l} -> 153 | if T.get_positive cell 154 | then print.fail "%s%s\n" reset_line (T.print_fail cell name l) 155 | else print.info "%s%s\n" reset_line (T.print_expected_failure cell l) 156 | | R.Failed_other {msg} -> 157 | print.fail "%s%s\n" reset_line (T.print_fail_other name ~msg); 158 | | R.Error {instance; exn; backtrace} -> 159 | print.err "%s%s\n" reset_line 160 | (T.print_error ~st:backtrace cell name (instance,exn)); 161 | ) 162 | 163 | let print_std = { info = Printf.printf; fail = Printf.printf; err = Printf.printf } 164 | 165 | let parse_cli ~full_options argv = 166 | let print_list = ref false in 167 | let set_verbose () = set_verbose true in 168 | let set_long_tests () = set_long_tests true in 169 | let set_backtraces () = Printexc.record_backtrace true in 170 | let set_list () = print_list := true in 171 | let colors = ref true in 172 | let slow = ref 0 in 173 | let options = Arg.align ( 174 | [ "-v", Arg.Unit set_verbose, " " 175 | ; "--verbose", Arg.Unit set_verbose, " enable verbose tests" 176 | ; "--colors", Arg.Set colors, " colored output" 177 | ; "--no-colors", Arg.Clear colors, " disable colored output" 178 | ] @ 179 | (if full_options then 180 | [ "-l", Arg.Unit set_list, " " 181 | ; "--list", Arg.Unit set_list, " print list of tests (2 lines each)" 182 | ; "--slow", Arg.Set_int slow, " print the slowest tests" 183 | ] else [] 184 | ) @ 185 | [ "-s", Arg.Set_int seed, " " 186 | ; "--seed", Arg.Set_int seed, " set random seed (to repeat tests)" 187 | ; "--long", Arg.Unit set_long_tests, " run long tests" 188 | ; "-bt", Arg.Unit set_backtraces, " enable backtraces" 189 | ; "--debug-shrink", Arg.String set_debug_shrink, " enable shrinking debug to " 190 | ; "--debug-shrink-list", Arg.String set_debug_shrink_list, " filter test to debug shrinking on" 191 | ] 192 | ) in 193 | Arg.parse_argv argv options (fun _ ->()) "run QCheck test suite"; 194 | let cli_rand = setup_random_state_ ~colors:!colors () in 195 | { cli_verbose=verbose(); cli_long_tests=long_tests(); cli_rand; 196 | cli_print_list= !print_list; cli_slow_test= !slow; 197 | cli_colors= !colors; cli_debug_shrink = debug_shrink(); 198 | cli_debug_shrink_list = debug_shrink_list(); } 199 | end 200 | 201 | open Raw 202 | 203 | (* Counter for a test's instances *) 204 | type counter = { 205 | start : float; 206 | expected : int; 207 | mutable gen : int; 208 | mutable passed : int; 209 | mutable failed : int; 210 | mutable errored : int; 211 | } 212 | 213 | type res = 214 | | Res : 'a QCheck2.Test.cell * 'a QCheck2.TestResult.t -> res 215 | 216 | type handler = { 217 | handler : 'a. 'a QCheck2.Test.handler; 218 | } 219 | 220 | type handler_gen = 221 | colors:bool -> 222 | debug_shrink:(out_channel option) -> 223 | debug_shrink_list:(string list) -> 224 | size:int -> out:out_channel -> verbose:bool -> counter -> handler 225 | 226 | let pp_counter ~size out c = 227 | let t = Unix.gettimeofday () -. c.start in 228 | Printf.fprintf out "%*d %*d %*d %*d / %*d %7.1fs" 229 | size c.gen size c.errored size c.failed 230 | size c.passed size c.expected t 231 | 232 | let debug_shrinking_counter_example cell out x = 233 | match QCheck2.Test.get_print_opt cell with 234 | | None -> Printf.fprintf out "" 235 | | Some print -> Printf.fprintf out "%s" (print x) 236 | 237 | let debug_shrinking_choices ~colors ~out ~name cell ~step x = 238 | Printf.fprintf out "\n~~~ %a %s\n\n" 239 | (Color.pp_str_c ~colors `Cyan) "Shrink" (String.make 69 '~'); 240 | Printf.fprintf out 241 | "Test %s successfully shrunk counter example (step %d) to:\n\n%a\n%!" 242 | name step 243 | (debug_shrinking_counter_example cell) x 244 | 245 | let default_handler 246 | ~colors ~debug_shrink ~debug_shrink_list 247 | ~size ~out ~verbose c = 248 | let handler name cell r = 249 | let st = function 250 | | QCheck2.Test.Generating -> "generating" 251 | | QCheck2.Test.Collecting _ -> "collecting" 252 | | QCheck2.Test.Testing _ -> " testing" 253 | | QCheck2.Test.Shrunk (i, _) -> 254 | Printf.sprintf "shrinking: %4d" i 255 | | QCheck2.Test.Shrinking (i, j, _) -> 256 | Printf.sprintf "shrinking: %4d.%04d" i j 257 | in 258 | (* debug shrinking choices *) 259 | begin match r with 260 | | QCheck2.Test.Shrunk (step, x) -> 261 | begin match debug_shrink with 262 | | None -> () 263 | | Some out -> 264 | let go = 265 | match debug_shrink_list with 266 | | [] -> true 267 | | test_list -> List.mem name test_list 268 | in 269 | if not go then () 270 | else 271 | debug_shrinking_choices 272 | ~colors ~out ~name cell ~step x 273 | end 274 | | _ -> 275 | () 276 | end; 277 | (* use timestamps for rate-limiting *) 278 | let now=Unix.gettimeofday() in 279 | if verbose && now -. !last_msg > get_time_between_msg () then ( 280 | last_msg := now; 281 | Printf.fprintf out "%s[ ] %a %s (%s)%!" 282 | (if colors then Color.reset_line else "\n") 283 | (pp_counter ~size) c name (st r) 284 | ) 285 | in 286 | { handler; } 287 | 288 | let step ~colors ~size ~out ~verbose c name _ _ r = 289 | let aux = function 290 | | QCheck2.Test.Success -> c.passed <- c.passed + 1 291 | | QCheck2.Test.Failure -> c.failed <- c.failed + 1 292 | | QCheck2.Test.FalseAssumption -> () 293 | | QCheck2.Test.Error _ -> c.errored <- c.errored + 1 294 | in 295 | c.gen <- c.gen + 1; 296 | aux r; 297 | let now=Unix.gettimeofday() in 298 | if verbose && now -. !last_msg > get_time_between_msg () then ( 299 | last_msg := now; 300 | Printf.fprintf out "%s[ ] %a %s%!" 301 | (if colors then Color.reset_line else "\n") (pp_counter ~size) c name 302 | ) 303 | 304 | let callback ~size ~out ~verbose ~colors c name cell r = 305 | let pass = 306 | if QCheck2.Test.get_positive cell 307 | then QCheck2.TestResult.is_success r 308 | else QCheck2.TestResult.is_failed r in 309 | let color = if pass then `Green else `Red in 310 | if verbose then ( 311 | (* print final test status line regardless of rate-limiting for responsive user feedback *) 312 | Printf.fprintf out "%s[%a] %a %s\n%!" 313 | (if colors then Color.reset_line else "\n") 314 | (Color.pp_str_c ~bold:true ~colors color) (if pass then "✓" else "✗") 315 | (pp_counter ~size) c name 316 | ) 317 | 318 | let print_inst cell x = 319 | match QCheck2.Test.get_print_opt cell with 320 | | Some f -> f x 321 | | None -> "" 322 | 323 | let expect long cell = 324 | let count = QCheck2.Test.get_count cell in 325 | if long then QCheck2.Test.get_long_factor cell * count else count 326 | 327 | let expect_size long cell = 328 | let rec aux n = if n < 10 then 1 else 1 + (aux (n / 10)) in 329 | aux (expect long cell) 330 | 331 | (* print user messages for a test *) 332 | let print_messages ~colors out cell l = 333 | if l<>[] then ( 334 | Printf.fprintf out 335 | "\n+++ %a %s\n\nMessages for test %s:\n\n%!" 336 | (Color.pp_str_c ~colors `Blue) "Messages" 337 | (String.make 68 '+') (QCheck2.Test.get_name cell); 338 | List.iter (Printf.fprintf out "%s\n%!") l 339 | ) 340 | 341 | let print_success ~colors out cell r = 342 | begin match QCheck2.TestResult.collect r with 343 | | None -> () 344 | | Some tbl -> 345 | Printf.fprintf out 346 | "\n+++ %a %s\n\nCollect results for test %s:\n\n%s%!" 347 | (Color.pp_str_c ~colors `Blue) "Collect" 348 | (String.make 68 '+') (QCheck2.Test.get_name cell) (QCheck2.Test.print_collect tbl) 349 | end; 350 | List.iter (fun msg -> 351 | Printf.fprintf out 352 | "\n!!! %a %s\n\nWarning for test %s:\n\n%s%!" 353 | (Color.pp_str_c ~colors `Yellow) "Warning" (String.make 68 '!') 354 | (QCheck2.Test.get_name cell) msg) 355 | (QCheck2.TestResult.warnings r); 356 | 357 | if QCheck2.TestResult.stats r <> [] then 358 | Printf.fprintf out 359 | "\n+++ %a %s\n%!" 360 | (Color.pp_str_c ~colors `Blue) ("Stats for " ^ QCheck2.Test.get_name cell) 361 | (String.make 56 '+'); 362 | List.iter 363 | (fun st -> Printf.fprintf out "\n%s%!" (QCheck2.Test.print_stat st)) 364 | (QCheck2.TestResult.stats r); 365 | () 366 | 367 | let print_fail ~colors out cell c_ex = 368 | Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-'); 369 | Printf.fprintf out "Test %s failed (%d shrink steps):\n\n%s\n%!" 370 | (QCheck2.Test.get_name cell) c_ex.QCheck2.TestResult.shrink_steps 371 | (print_inst cell c_ex.QCheck2.TestResult.instance); 372 | print_messages ~colors out cell c_ex.QCheck2.TestResult.msg_l 373 | 374 | let print_fail_other ~colors out cell msg = 375 | Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-'); 376 | Printf.fprintf out "Test %s failed:\n\n%s\n%!" (QCheck2.Test.get_name cell) msg 377 | 378 | let print_expected_failure ~colors out cell c_ex = 379 | Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Blue) "Info" (String.make 71 '-'); 380 | Printf.fprintf out "Negative test %s failed as expected (%d shrink steps):\n\n%s\n%!" 381 | (QCheck2.Test.get_name cell) c_ex.QCheck2.TestResult.shrink_steps 382 | (print_inst cell c_ex.QCheck2.TestResult.instance); 383 | print_messages ~colors out cell c_ex.QCheck2.TestResult.msg_l 384 | 385 | let print_error ~colors out cell c_ex exn bt = 386 | Printf.fprintf out "\n=== %a %s\n\n" (Color.pp_str_c ~colors `Red) "Error" (String.make 70 '='); 387 | Printf.fprintf out "Test %s errored on (%d shrink steps):\n\n%s\n\nexception %s\n%s\n%!" 388 | (QCheck2.Test.get_name cell) 389 | c_ex.QCheck2.TestResult.shrink_steps 390 | (print_inst cell c_ex.QCheck2.TestResult.instance) 391 | (Printexc.to_string exn) 392 | bt; 393 | print_messages ~colors out cell c_ex.QCheck2.TestResult.msg_l 394 | 395 | let run_tests 396 | ?(handler=default_handler) 397 | ?(colors=true) ?(verbose=verbose()) ?(long=long_tests()) 398 | ?(debug_shrink=debug_shrink()) ?(debug_shrink_list=debug_shrink_list()) 399 | ?(out=stdout) ?rand l = 400 | let rand = match rand with Some x -> x | None -> random_state_ ~colors () in 401 | let module T = QCheck2.Test in 402 | let module R = QCheck2.TestResult in 403 | let pp_color = Color.pp_str_c ~bold:true ~colors in 404 | let size = List.fold_left (fun acc (T.Test cell) -> 405 | max acc (expect_size long cell)) 4 l in 406 | if verbose then 407 | Printf.fprintf out 408 | "%*s %*s %*s %*s / %*s time test name\n%!" 409 | (size + 4) "generated" size "error" 410 | size "fail" size "pass" size "total"; 411 | let aux_map (T.Test cell) = 412 | let rand = Random.State.copy rand in 413 | let expected = expect long cell in 414 | let start = Unix.gettimeofday () in 415 | let c = { 416 | start; expected; gen = 0; 417 | passed = 0; failed = 0; errored = 0; 418 | } in 419 | if verbose then ( 420 | (* print initial test status line regardless of rate-limiting for responsive user feedback *) 421 | last_msg := Unix.gettimeofday(); 422 | Printf.fprintf out "%s[ ] %a %s%!" 423 | (if colors then Color.reset_line else "") 424 | (pp_counter ~size) c (T.get_name cell)); 425 | let r = QCheck2.Test.check_cell ~long ~rand 426 | ~handler:(handler ~colors ~debug_shrink ~debug_shrink_list 427 | ~size ~out ~verbose c).handler 428 | ~step:(step ~colors ~size ~out ~verbose c) 429 | ~call:(callback ~size ~out ~verbose ~colors c) 430 | cell 431 | in 432 | Res (cell, r) 433 | in 434 | let res = List.map aux_map l in 435 | let aux_fold (total, fail, error, warns) (Res (cell, r)) = 436 | let warns = warns + List.length (R.get_warnings r) in 437 | let acc = match R.get_state r, QCheck2.Test.get_positive cell with 438 | | R.Success, true -> 439 | print_success ~colors out cell r; 440 | (total + 1, fail, error, warns) 441 | | R.Success, false -> 442 | let msg = Printf.sprintf "Negative test %s succeeded but was expected to fail" (QCheck2.Test.get_name cell) in 443 | print_fail_other ~colors out cell msg; 444 | (total + 1, fail + 1, error, warns) 445 | | R.Failed {instances=l}, true -> 446 | List.iter (print_fail ~colors out cell) l; 447 | (total + 1, fail + 1, error, warns) 448 | | R.Failed {instances=l}, false -> 449 | if verbose then List.iter (print_expected_failure ~colors out cell) l; 450 | (total + 1, fail, error, warns) 451 | | R.Failed_other {msg}, _ -> (* Failed_other is also considered a failure *) 452 | print_fail_other ~colors out cell msg; 453 | (total + 1, fail + 1, error, warns) 454 | | R.Error {instance=c_ex; exn; backtrace=bt}, _ -> (* Error is always considered a failure *) 455 | print_error ~colors out cell c_ex exn bt; 456 | (total + 1, fail, error + 1, warns) 457 | in 458 | acc 459 | in 460 | let total, fail, error, warns = List.fold_left aux_fold (0, 0, 0,0) res in 461 | Printf.fprintf out "%s\n" (String.make 80 '='); 462 | if warns > 0 then Printf.fprintf out "%d warning(s)\n" warns; 463 | if fail = 0 && error = 0 then ( 464 | Printf.fprintf out "%a (ran %d tests)\n%!" 465 | (pp_color `Green) "success" total; 466 | 0 467 | ) else ( 468 | Printf.fprintf out 469 | "%a (%d tests failed, %d tests errored, ran %d tests)\n%!" 470 | (pp_color `Red) "failure" fail error total; 471 | 1 472 | ) 473 | 474 | let run_tests_main ?(argv=Sys.argv) l = 475 | try 476 | let cli_args = parse_cli ~full_options:false argv in 477 | exit 478 | (run_tests l 479 | ~colors:cli_args.cli_colors 480 | ~verbose:cli_args.cli_verbose 481 | ~long:cli_args.cli_long_tests ~out:stdout ~rand:cli_args.cli_rand) 482 | with 483 | | Arg.Bad msg -> print_endline msg; exit 1 484 | | Arg.Help msg -> print_endline msg; exit 0 485 | -------------------------------------------------------------------------------- /src/runner/QCheck_base_runner.mli: -------------------------------------------------------------------------------- 1 | (* 2 | QCheck: Random testing for OCaml 3 | copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard 4 | all rights reserved. 5 | *) 6 | 7 | (** {1 Runners for Tests} 8 | 9 | Once you have built tests using {!QCheck.Test.make} or {!QCheck2.Test.make}, 10 | you need to run them. This module contains several {b runners}, which are 11 | designed to run every test and report the result. 12 | 13 | By default, you can use {!run_tests} in a test program as follows: 14 | {[ 15 | let testsuite = [ 16 | Test.make ...; 17 | Test.make ...; 18 | ] 19 | 20 | let () = 21 | let errcode = QCheck_base_runner.run_tests ~verbose:true testsuite in 22 | exit errcode 23 | ]} 24 | which will run the tests, and exit the program. The error code 25 | will be 0 if all tests pass, 1 otherwise. 26 | 27 | {!run_tests_main} can be used as a shortcut for that, also 28 | featuring command-line parsing (using [Arg]) to activate 29 | verbose mode and others. 30 | *) 31 | 32 | (** {2 State} *) 33 | 34 | val random_state : unit -> Random.State.t 35 | (** Access the current random state *) 36 | 37 | val verbose : unit -> bool 38 | (** Is the default mode verbose or quiet? *) 39 | 40 | val long_tests : unit -> bool 41 | (** Is the default mode to run long tests or nor? *) 42 | 43 | val set_seed : int -> unit 44 | (** Change the {!random_state} by creating a new one, initialized with 45 | the given seed. *) 46 | 47 | val set_verbose : bool -> unit 48 | (** Change the value of [verbose ()] *) 49 | 50 | val set_long_tests : bool -> unit 51 | (** Change the value of [long_tests ()] *) 52 | 53 | 54 | (** {2 Console message printing} 55 | 56 | In verbose mode, by default [QCheck_base_runner] prints frequent sub-second 57 | messages suitable for an interactive console test run. This behaviour can be 58 | changed by the environment variable [QCHECK_MSG_INTERVAL]. Intervals are 59 | given in seconds and can also be decimal numbers. For example, setting 60 | {[ 61 | QCHECK_MSG_INTERVAL=7.5 62 | ]} 63 | will only print a console message every 7.5 seconds. This feature can be 64 | useful in a CI context, where updates are printed on consecutive lines and 65 | one may want to avoid overflowing the CI log files with too many lines. 66 | 67 | Note: The start and finishing message for each test is printed eagerly 68 | in verbose mode regardless of the specified message interval. 69 | *) 70 | 71 | val get_time_between_msg : unit -> float 72 | (** Get the minimum time (in seconds) to wait between printing messages. 73 | @since 0.9 *) 74 | 75 | val set_time_between_msg : float -> unit 76 | (** Set the minimum time (in seconds) between messages. 77 | @since 0.9 *) 78 | 79 | 80 | (** {2 Event handlers} *) 81 | 82 | type counter = private { 83 | start : float; 84 | expected : int; 85 | mutable gen : int; 86 | mutable passed : int; 87 | mutable failed : int; 88 | mutable errored : int; 89 | } 90 | (** The type of counter used to keep tracks of the events received for a given 91 | test cell. *) 92 | 93 | type handler = { 94 | handler : 'a. 'a QCheck2.Test.handler; 95 | } 96 | (** A type to represent polymorphic-enough handlers for test cells. *) 97 | 98 | type handler_gen = 99 | colors:bool -> 100 | debug_shrink:(out_channel option) -> 101 | debug_shrink_list:(string list) -> 102 | size:int -> out:out_channel -> verbose:bool -> counter -> handler 103 | (** An alias type to a generator of handlers for test cells. *) 104 | 105 | val default_handler : handler_gen 106 | (** The default handler used. *) 107 | 108 | val debug_shrinking_choices: 109 | colors:bool -> 110 | out:out_channel -> 111 | name:string -> 'a QCheck2.Test.cell -> step:int -> 'a -> unit 112 | (** The function used by the default handler to debug shrinking choices. 113 | This can be useful to outside users trying to reproduce some of the 114 | base-runner behavior. 115 | 116 | @since 0.19 117 | *) 118 | 119 | (** {2 Run a Suite of Tests and Get Results} *) 120 | 121 | val run_tests : 122 | ?handler:handler_gen -> 123 | ?colors:bool -> ?verbose:bool -> ?long:bool -> 124 | ?debug_shrink:(out_channel option) -> 125 | ?debug_shrink_list:(string list) -> 126 | ?out:out_channel -> ?rand:Random.State.t -> 127 | QCheck2.Test.t list -> int 128 | (** Run a suite of tests, and print its results. This is an heritage from 129 | the "qcheck" library. 130 | @return an error code, [0] if all tests passed, [1] otherwise. 131 | @param colors if true (default), colorful output 132 | @param verbose if true, prints more information about test cases (default: [false]) 133 | @param long if true, runs the long versions of the tests (default: [false]) 134 | @param debug_shrink [debug_shrink:(Some ch)] writes a log of successful shrink 135 | attempts to channel [ch], for example [~debug_shrink:(Some (open_out "mylog.txt"))]. 136 | Use together with a non-empty list in [~debug_shrink_list]. 137 | @param debug_shrink_list the test names to log successful shrink attempts for, 138 | for example [~debug_shrink_list:["list_rev_is_involutive"]]. 139 | Requires [~debug_shrink] to be [Some ch]. 140 | @param out print output to the provided channel (default: [stdout]) 141 | @param rand start the test runner in the provided RNG state *) 142 | 143 | val run_tests_main : ?argv:string array -> QCheck2.Test.t list -> 'a 144 | (** Can be used as the main function of a test file. Exits with a non-0 code 145 | if the tests fail. It refers to {!run_tests} for actually running tests 146 | after CLI options have been parsed. 147 | 148 | The available options are: 149 | 150 | - "--verbose" (or "-v") for activating verbose tests 151 | - "--seed " (or "-s ") for repeating a previous run by setting the random seed 152 | - "--long" for running the long versions of the tests 153 | 154 | Below is an example of the output of the [run_tests] and [run_tests_main] 155 | function: 156 | {v 157 | random seed: 438308050 158 | generated error; fail; pass / total - time -- test name 159 | [✓] (1000) 0 ; 0 ; 1000 / 1000 -- 0.5s -- list_rev_is_involutive 160 | [✗] ( 1) 0 ; 1 ; 0 / 10 -- 0.0s -- should_fail_sort_id 161 | [✗] ( 1) 1 ; 0 ; 0 / 10 -- 0.0s -- should_error_raise_exn 162 | [✓] (1000) 0 ; 0 ; 1000 / 1000 -- 0.0s -- collect_results 163 | 164 | --- Failure -------------------------------------------------------------------- 165 | 166 | Test should_fail_sort_id failed (11 shrink steps): 167 | 168 | [1; 0] 169 | 170 | === Error ====================================================================== 171 | 172 | Test should_error_raise_exn errored on (62 shrink steps): 173 | 174 | 0 175 | 176 | exception QCheck_runner_test.Error 177 | Raised at file "example/QCheck_runner_test.ml", line 20, characters 20-25 178 | Called from file "src/QCheck.ml", line 839, characters 13-33 179 | 180 | 181 | +++ Collect ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 182 | 183 | Collect results for test collect_results: 184 | 185 | 4: 207 cases 186 | 3: 190 cases 187 | 2: 219 cases 188 | 1: 196 cases 189 | 0: 188 cases 190 | 191 | ================================================================================ 192 | failure (1 tests failed, 1 tests errored, ran 4 tests) 193 | v} 194 | *) 195 | 196 | (** {2 Utils for colored output} *) 197 | module Color : sig 198 | type color = 199 | [ `Red 200 | | `Yellow 201 | | `Green 202 | | `Blue 203 | | `Normal 204 | | `Cyan 205 | ] 206 | 207 | val reset_line : string 208 | val pp_str_c : ?bold:bool -> colors:bool -> color -> out_channel -> string -> unit 209 | end 210 | 211 | (** {2 Internal Utils} 212 | 213 | We provide {b NO} stability guarantee for this module. Use at your 214 | own risks. *) 215 | module Raw : sig 216 | type ('b,'c) printer = { 217 | info: 'a. ('a,'b,'c,unit) format4 -> 'a; 218 | fail: 'a. ('a,'b,'c,unit) format4 -> 'a; 219 | err: 'a. ('a,'b,'c,unit) format4 -> 'a; 220 | } 221 | 222 | val print_std : (out_channel, unit) printer 223 | 224 | (* main callback for display *) 225 | val callback : 226 | colors:bool -> 227 | verbose:bool -> 228 | print_res:bool -> 229 | print:('a, 'b) printer -> 230 | string -> 'c QCheck2.Test.cell -> 'c QCheck2.TestResult.t -> unit 231 | 232 | type cli_args = { 233 | cli_verbose : bool; 234 | cli_long_tests : bool; 235 | cli_print_list : bool; 236 | cli_rand : Random.State.t; 237 | cli_slow_test : int; (* how many slow tests to display? *) 238 | cli_colors: bool; 239 | cli_debug_shrink : out_channel option; 240 | cli_debug_shrink_list : string list; 241 | } 242 | 243 | val parse_cli : full_options:bool -> string array -> cli_args 244 | end 245 | -------------------------------------------------------------------------------- /src/runner/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name qcheck_runner) 4 | (public_name qcheck-core.runner) 5 | (wrapped false) 6 | (libraries qcheck-core) 7 | (flags :standard -warn-error -a+8 -safe-string) 8 | ) 9 | -------------------------------------------------------------------------------- /test/core/QCheck2_expect_test.ml: -------------------------------------------------------------------------------- 1 | open QCheck2_tests 2 | 3 | (* Calling runners *) 4 | 5 | let () = QCheck_base_runner.set_seed 1234 6 | let _ = 7 | QCheck_base_runner.run_tests ~colors:false ( 8 | Overall.tests @ 9 | Generator.tests @ 10 | Shrink.tests @ 11 | Function.tests @ 12 | FindExample.tests @ 13 | Stats.tests) 14 | 15 | let () = QCheck_base_runner.set_seed 153870556 16 | let _ = QCheck_base_runner.run_tests ~colors:false [Stats.int_dist_empty_bucket] 17 | -------------------------------------------------------------------------------- /test/core/QCheck_expect_test.ml: -------------------------------------------------------------------------------- 1 | open QCheck_tests 2 | 3 | (* Calling runners *) 4 | 5 | let () = QCheck_base_runner.set_seed 1234 6 | let _ = 7 | QCheck_base_runner.run_tests ~colors:false ( 8 | Overall.tests @ 9 | Generator.tests @ 10 | Shrink.tests @ 11 | Function.tests @ 12 | FindExample.tests @ 13 | Stats.tests) 14 | 15 | let () = QCheck_base_runner.set_seed 153870556 16 | let _ = QCheck_base_runner.run_tests ~colors:false [Stats.int_dist_empty_bucket] 17 | -------------------------------------------------------------------------------- /test/core/QCheck_unit_tests.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module Shrink = struct 4 | 5 | let trace_false shrinker x = 6 | let res = ref [] in 7 | shrinker x (fun x -> res := x::!res); 8 | List.rev !res 9 | 10 | let trace_true shrinker x = 11 | let rec loop x = 12 | match Iter.find (fun _ -> true) (shrinker x) with 13 | | None -> [] 14 | | Some y -> y::loop y in 15 | loop x 16 | 17 | let alco_check typ func msg_suffix (msg,input,expected) = 18 | Alcotest.(check (list typ)) (msg ^ " - " ^ msg_suffix) expected (func input) 19 | 20 | let test_bool () = 21 | List.iter (alco_check Alcotest.bool (trace_false Shrink.bool) "on repeated failure") 22 | [ ("bool true", true, [false]); 23 | ("bool false", false, []) ]; 24 | List.iter (alco_check Alcotest.bool (trace_true Shrink.bool) "on repeated success") 25 | [ ("bool true", true, [false]); 26 | ("bool false", false, []) ] 27 | 28 | let test_int () = 29 | List.iter (alco_check Alcotest.int (trace_false Shrink.int) "on repeated failure") 30 | [ ("int 100", 100, [50; 75; 88; 94; 97; 99]); 31 | ("int 1000", 1000, [500; 750; 875; 938; 969; 985; 993; 997; 999]); 32 | ("int (-26)", -26, [-13; -20; -23; -25]) ]; 33 | List.iter (alco_check Alcotest.int (trace_true Shrink.int) "on repeated success") 34 | [ ("int 100", 100, [50; 25; 13; 7; 4; 2; 1; 0]); 35 | ("int 1000", 1000, [500; 250; 125; 63; 32; 16; 8; 4; 2; 1; 0]); 36 | ("int (-26)", -26, [-13; -7; -4; -2; -1; 0]) ] 37 | 38 | let test_int32 () = 39 | List.iter (alco_check Alcotest.int32 (trace_false Shrink.int32) "on repeated failure") 40 | [ ("int 100", 100l, [50l; 75l; 88l; 94l; 97l; 99l]); 41 | ("int 1000", 1000l, [500l; 750l; 875l; 938l; 969l; 985l; 993l; 997l; 999l]); 42 | ("int (-26)", -26l, [-13l; -20l; -23l; -25l]) ]; 43 | List.iter (alco_check Alcotest.int32 (trace_true Shrink.int32) "on repeated success") 44 | [ ("int 100", 100l, [50l; 25l; 13l; 7l; 4l; 2l; 1l; 0l]); 45 | ("int 1000", 1000l, [500l; 250l; 125l; 63l; 32l; 16l; 8l; 4l; 2l; 1l; 0l]); 46 | ("int (-26)", -26l, [-13l; -7l; -4l; -2l; -1l; 0l]) ] 47 | 48 | let test_int64 () = 49 | List.iter (alco_check Alcotest.int64 (trace_false Shrink.int64) "on repeated failure") 50 | [ ("int 100", 100L, [50L; 75L; 88L; 94L; 97L; 99L]); 51 | ("int 1000", 1000L, [500L; 750L; 875L; 938L; 969L; 985L; 993L; 997L; 999L]); 52 | ("int (-26)", -26L, [-13L; -20L; -23L; -25L]) ]; 53 | List.iter (alco_check Alcotest.int64 (trace_true Shrink.int64) "on repeated success") 54 | [ ("int 100", 100L, [50L; 25L; 13L; 7L; 4L; 2L; 1L; 0L]); 55 | ("int 1000", 1000L, [500L; 250L; 125L; 63L; 32L; 16L; 8L; 4L; 2L; 1L; 0L]); 56 | ("int (-26)", -26L, [-13L; -7L; -4L; -2L; -1L; 0L]) ] 57 | 58 | let test_char () = 59 | List.iter (alco_check Alcotest.char (trace_false Shrink.char) "on repeated failure") 60 | [ ("char 'a'", 'a', []); 61 | ("char 'z'", 'z', ['n'; 't'; 'w'; 'y']); 62 | ("char 'A'", 'A', ['Q'; 'I'; 'E'; 'C'; 'B']); 63 | ("char '~'", '~', ['p'; 'w'; '{'; '}']) ]; 64 | List.iter (alco_check Alcotest.char (trace_true Shrink.char) "on repeated success") 65 | [ ("char 'a'", 'a', []); 66 | ("char 'z'", 'z', ['n'; 'h'; 'e'; 'c'; 'b'; 'a']); 67 | ("char 'A'", 'A', ['Q'; 'Y'; ']'; '_'; '`'; 'a']); 68 | ("char '~'", '~', ['p'; 'i'; 'e'; 'c'; 'b'; 'a']); ] 69 | 70 | let test_char_numeral () = 71 | List.iter (alco_check Alcotest.char (trace_false Shrink.char_numeral) "on repeated failure") 72 | [ ("char '0'", '0', []); 73 | ("char '9'", '9', ['5'; '7'; '8']) ]; 74 | List.iter (alco_check Alcotest.char (trace_true Shrink.char_numeral) "on repeated success") 75 | [ ("char '0'", '0', []); 76 | ("char '9'", '9', ['5'; '3'; '2'; '1'; '0']); ] 77 | 78 | let test_char_printable () = 79 | List.iter (alco_check Alcotest.char (trace_false Shrink.char_printable) "on repeated failure") 80 | [ ("char 'A'", 'A', ['Q'; 'I'; 'E'; 'C'; 'B']); 81 | ("char 'a'", 'a', []); 82 | ("char ' '", ' ', ['@'; '0'; '('; '$'; '"'; '!']); 83 | ("char '~'", '~', ['p'; 'w'; '{'; '}']); 84 | ("char '\\n'", '\n', ['p'; 'w'; '{'; '}']); ]; 85 | List.iter (alco_check Alcotest.char (trace_true Shrink.char_printable) "on repeated success") 86 | [ ("char 'A'", 'A', ['Q'; 'Y'; ']'; '_'; '`'; 'a']); 87 | ("char 'a'", 'a', []); 88 | ("char ' '", ' ', ['@'; 'P'; 'X'; '\\'; '^'; '_'; '`'; 'a']); 89 | ("char '~'", '~', ['p'; 'i'; 'e'; 'c'; 'b'; 'a']); 90 | ("char '\\n'", '\n', ['p'; 'i'; 'e'; 'c'; 'b'; 'a']); ] 91 | 92 | let test_string () = 93 | List.iter (alco_check Alcotest.string (trace_false Shrink.string) "on repeated failure") 94 | [ ("string \"\"", "", []); 95 | ("string \"a\"", "a", [""]); 96 | ("string \"aa\"", "aa", [""; "a"]); 97 | ("string \"aaaa\"", "aaaa", ["aa"; "aa"; "aaa"]); 98 | ("string \"abcd\"", "abcd", ["ab"; "cd"; "acd"; "bcd"; "aacd"; "abbd"; "abcc"]); 99 | ("string \"E'*\"", "E'*", ["E'"; "*"; "E*"; "'*"; "S'*"; "L'*"; "H'*"; "F'*"; "ED*"; 100 | "E5*"; "E.*"; "E**"; "E(*"; "E'E"; "E'7"; "E'0"; "E'-"; "E'+"]); 101 | ("string \"vi5x92xgG\"", "vi5x92xgG", (* A less exhaustive string shrinker would be preferable *) 102 | ["vi5x9"; "vi52xgG"; "vix92xgG"; "5x92xgG"; 103 | "v5x92xgG"; "i5x92xgG"; "li5x92xgG"; "qi5x92xgG"; "ti5x92xgG"; "ui5x92xgG"; 104 | "ve5x92xgG"; "vg5x92xgG"; "vh5x92xgG"; 105 | "viKx92xgG"; "vi@x92xgG"; "vi:x92xgG"; "vi7x92xgG"; "vi6x92xgG"; 106 | "vi5m92xgG"; "vi5s92xgG"; "vi5v92xgG"; "vi5w92xgG"; 107 | "vi5xM2xgG"; "vi5xC2xgG"; "vi5x>2xgG"; "vi5x;2xgG"; "vi5x:2xgG"; 108 | "vi5x9IxgG"; "vi5x9=xgG"; "vi5x97xgG"; "vi5x94xgG"; "vi5x93xgG"; 109 | "vi5x92mgG"; "vi5x92sgG"; "vi5x92vgG"; "vi5x92wgG"; 110 | "vi5x92xdG"; "vi5x92xfG"; 111 | "vi5x92xgT"; "vi5x92xgM"; "vi5x92xgJ"; "vi5x92xgH"]); 112 | ("string \"~~~~\"", "~~~~", ["~~"; "~~"; "~~~"; "p~~~"; "w~~~"; "{~~~"; "}~~~"; "~p~~"; 113 | "~w~~"; "~{~~"; "~}~~"; "~~p~"; "~~w~"; "~~{~"; "~~}~"; 114 | "~~~p"; "~~~w"; "~~~{"; "~~~}"]); ]; 115 | List.iter (alco_check Alcotest.string (trace_true Shrink.string) "on repeated success") 116 | [ ("string \"\"", "", []); 117 | ("string \"a\"", "a", [""]); 118 | ("string \"aa\"", "aa", [""]); 119 | ("string \"aaaa\"", "aaaa", ["aa"; ""]); 120 | ("string \"abcd\"", "abcd", ["ab"; ""]); 121 | ("string \"E'*\"", "E'*", ["E'"; ""]); 122 | ("string \"vi5x92xgG\"", "vi5x92xgG", ["vi5x9"; "vi5"; "vi"; ""]); ] 123 | 124 | let test_int_list () = 125 | List.iter (alco_check Alcotest.(list int) (trace_false (Shrink.list_spine)) "on repeated failure") 126 | [ ("list int [0]", [0], [[]]); 127 | ("list int [0;1]", [0;1], [[]; [0]; [1]]); 128 | ("list int [0;1;2]", [0;1;2], [[0; 1]; [2]; [0; 2]; [1; 2]]); 129 | ("list int [0;1;2;3]", [0;1;2;3], [[0; 1]; [2; 3]; [0; 2; 3]; [1; 2; 3]]); 130 | ("list int [0;0]", [0;0], [[]; [0]]); 131 | ("list int [0;0;0]", [0;0;0], [[0; 0]; [0]; [0; 0]]); 132 | ("list int [0;0;0;0]", [0;0;0;0], [[0; 0]; [0; 0]; [0; 0; 0]]); ]; 133 | List.iter (alco_check Alcotest.(list int) (trace_true (Shrink.list_spine)) "on repeated success") 134 | [ ("list int [0]", [0], [[]]); 135 | ("list int [0;1]", [0;1], [[]]); 136 | ("list int [0;1;2]", [0;1;2], [[0; 1]; []]); 137 | ("list int [0;1;2;3]", [0;1;2;3], [[0; 1]; []]); 138 | ("list int [0;0]", [0;0], [[]]); 139 | ("list int [0;0;0]", [0;0;0], [[0; 0]; []]); 140 | ("list int [0;0;0;0]", [0;0;0;0], [[0; 0]; []]); ] 141 | 142 | let test_int32_list () = (* use int32 as a boxed type and List.map to force run-time allocations *) 143 | List.iter (alco_check Alcotest.(list int32) (trace_false (Shrink.list_spine)) "on repeated failure") 144 | [ ("list int32 [0l]", List.map Int32.of_int [0], [[]]); 145 | ("list int32 [0l;1l]", List.map Int32.of_int [0;1], [[]; [0l]; [1l]]); 146 | ("list int32 [0l;1l;2l]", List.map Int32.of_int [0;1;2], [[0l; 1l]; [2l]; [0l; 2l]; [1l; 2l]]); 147 | ("list int32 [0l;1l;2l;3l]", List.map Int32.of_int [0;1;2;3], [[0l; 1l]; [2l; 3l]; [0l; 2l; 3l]; [1l; 2l; 3l]]); 148 | ("list int32 [0l;0l]", List.map Int32.of_int [0;0], [[]; [0l]]); 149 | ("list int32 [0l;0l;0l]", List.map Int32.of_int [0;0;0], [[0l; 0l]; [0l]; [0l; 0l]]); 150 | ("list int32 [0l;0l;0l;0l]", List.map Int32.of_int [0;0;0;0], [[0l; 0l]; [0l; 0l]; [0l; 0l; 0l]]); ]; 151 | List.iter (alco_check Alcotest.(list int32) (trace_true (Shrink.list_spine)) "on repeated success") 152 | [ ("list int [0l]", List.map Int32.of_int [0], [[]]); 153 | ("list int [0l;1l]", List.map Int32.of_int [0;1], [[]]); 154 | ("list int [0l;1l;2l]", List.map Int32.of_int [0;1;2], [[0l; 1l]; []]); 155 | ("list int [0l;1l;2l;3l]", List.map Int32.of_int [0;1;2;3], [[0l; 1l]; []]); 156 | ("list int [0l;0l]", List.map Int32.of_int [0;0], [[]]); 157 | ("list int [0l;0l;0l]", List.map Int32.of_int [0;0;0], [[0l; 0l]; []]); 158 | ("list int [0l;0l;0l;0l]", List.map Int32.of_int [0;0;0;0], [[0l; 0l]; []]); ] 159 | 160 | let test_list_spine_compare () = 161 | let run_test () = QCheck.Shrink.list_spine [pred;succ] ignore in 162 | Alcotest.(check unit) "doesn't compare elements" () @@ run_test () 163 | 164 | let test_int_option () = 165 | List.iter (alco_check Alcotest.(option int) (trace_false Shrink.(option int)) "on repeated failure") 166 | [ ("option int Some 42", Some 42, [None; Some 21; Some 32; Some 37; Some 40; Some 41]); 167 | ("option int None", None, []) ]; 168 | List.iter (alco_check Alcotest.(option int) (trace_true Shrink.(option int)) "on repeated success") 169 | [ ("option int Some 42", Some 42, [None]); 170 | ("option int None", None, []) ] 171 | 172 | let test_int_string_result () = 173 | List.iter (alco_check Alcotest.(result int string) (trace_false Shrink.(result int string)) "on repeated failure") 174 | [ ("result int string Ok 55", Ok 55, [Ok 28; Ok 42; Ok 49; Ok 52; Ok 54]); 175 | ("result int string Error \"oops\"", Error "oops", [Error "oo"; Error "ps"; Error "ops"; Error "hops"; 176 | Error "lops"; Error "nops"; Error "ohps"; Error "olps"; 177 | Error "onps"; Error "oois"; Error "ooms"; Error "ooos"; 178 | Error "oopj"; Error "oopo"; Error "oopq"; Error "oopr"]) ]; 179 | List.iter (alco_check Alcotest.(result int string) (trace_true Shrink.(result int string)) "on repeated success") 180 | [ ("result int string Ok 55", Ok 55, [Ok 28; Ok 14; Ok 7; Ok 4; Ok 2; Ok 1; Ok 0]); 181 | ("result int string Error \"oops\"", Error "oops", [Error "oo"; Error ""]) ] 182 | 183 | let tests = ("Shrink", Alcotest.[ 184 | test_case "bool" `Quick test_bool; 185 | test_case "int" `Quick test_int; 186 | test_case "int32" `Quick test_int32; 187 | test_case "int64" `Quick test_int64; 188 | test_case "char" `Quick test_char; 189 | test_case "char_numeral" `Quick test_char_numeral; 190 | test_case "char_printable" `Quick test_char_printable; 191 | test_case "string" `Quick test_string; 192 | test_case "int list" `Quick test_int_list; 193 | test_case "int32 list" `Quick test_int32_list; 194 | test_case "list_spine" `Quick test_list_spine_compare; 195 | test_case "int option" `Quick test_int_option; 196 | test_case "(int,string) result" `Quick test_int_string_result; 197 | ]) 198 | end 199 | 200 | module Check_exn = struct 201 | 202 | (* String.starts_with was introduced in 4.13. 203 | Include the below to support pre-4.13 OCaml. *) 204 | let string_starts_with ~prefix s = 205 | let prefix_len = String.length prefix in 206 | prefix_len <= String.length s 207 | && prefix = String.sub s 0 prefix_len 208 | 209 | let check_exn = Test.check_exn 210 | 211 | let test_pass_trivial () = 212 | let run_test () = check_exn QCheck.(Test.make int (fun _ -> true)) in 213 | Alcotest.(check unit) "Success-trivial" () @@ run_test () 214 | 215 | let test_pass_random () = 216 | let run_test () = 217 | check_exn QCheck.(Test.make (list int) (fun l -> List.rev (List.rev l) = l)) in 218 | Alcotest.(check unit) "Success-random" () @@ run_test () 219 | 220 | let test_fail_always () = 221 | let name = "will-always-fail" in 222 | try 223 | check_exn QCheck.(Test.make ~name int (fun _ -> false)); 224 | Alcotest.failf "%s: Unexpected success" name 225 | with 226 | (Test.Test_fail (n,[c_ex_str])) -> 227 | Alcotest.(check string) (Printf.sprintf "%s: name" name) n name; 228 | if not (string_starts_with ~prefix:"0" c_ex_str) 229 | then 230 | Alcotest.failf "%s: counter-example prefix. Received \"%s\"" name c_ex_str 231 | 232 | let test_fail_random () = 233 | let name = "list is own reverse" in 234 | try 235 | check_exn QCheck.(Test.make ~name (list int) (fun l -> List.rev l = l)); 236 | Alcotest.failf "%s: Unexpected success" name 237 | with 238 | (Test.Test_fail (n,[c_ex_str])) -> 239 | Alcotest.(check string) (Printf.sprintf "%s: name" name) n name; 240 | if not (string_starts_with ~prefix:"[0; 1]" c_ex_str 241 | || string_starts_with ~prefix:"[0; -1]" c_ex_str) 242 | then 243 | Alcotest.failf "%s: counter-example prefix. Received \"%s\"" name c_ex_str 244 | 245 | exception MyError 246 | 247 | let test_error () = 248 | let name = "will-always-error" in 249 | try 250 | Printexc.record_backtrace false; (* for easier pattern-matching below *) 251 | check_exn QCheck.(Test.make ~name int (fun _ -> raise MyError)); 252 | Alcotest.failf "%s: Unexpected success" name 253 | with 254 | (Test.Test_error (n,c_ex_str,MyError,"")) -> 255 | Alcotest.(check string) (Printf.sprintf "%s: name" name) n name; 256 | if not (string_starts_with ~prefix:"0" c_ex_str) 257 | then 258 | Alcotest.failf "%s: counter-example prefix. Received \"%s\"" name c_ex_str 259 | 260 | let test_negative_trivial () = 261 | let run_test () = check_exn QCheck2.(Test.make_neg Gen.int (fun _ -> false)) in 262 | Alcotest.(check unit) "Success-negative-trivial" () @@ run_test () 263 | 264 | let test_negative_test_unexpected_success () = 265 | let name = "negative-trivial-test" in 266 | let run_test () = check_exn QCheck2.(Test.make_neg ~name Gen.int (fun _ -> true)) in 267 | try 268 | run_test (); 269 | Alcotest.failf "Negative test didn't raise expected exception." 270 | with 271 | Test.Test_unexpected_success n -> 272 | Alcotest.(check string) (Printf.sprintf "%s: name" name) n name 273 | 274 | let tests = 275 | ("Test.check_exn", Alcotest.[ 276 | test_case "check_exn pass trivial" `Quick test_pass_trivial; 277 | test_case "check_exn pass random" `Quick test_pass_random; 278 | test_case "check_exn fail always" `Quick test_fail_always; 279 | test_case "check_exn fail random" `Quick test_fail_random; 280 | test_case "check_exn Error" `Quick test_error; 281 | test_case "check_exn negative pass trivial" `Quick test_negative_trivial; 282 | test_case "check_exn Unexpected success" `Quick test_negative_test_unexpected_success; 283 | ]) 284 | end 285 | 286 | module TestCount = struct 287 | let test_count_n ?count expected = 288 | let (Test cell) = QCheck.(Test.make ?count int (fun _ -> true)) in 289 | let msg = Printf.sprintf "QCheck.Test.make ~count:%s |> get_count = %d" 290 | (Option.fold ~none:"None" ~some:string_of_int count) expected 291 | in 292 | Alcotest.(check int) msg expected (QCheck.Test.get_count cell) 293 | 294 | let test_count_10 () = test_count_n ~count:10 10 295 | 296 | let test_count_default () = test_count_n 100 297 | 298 | let test_count_env () = 299 | let () = Unix.putenv "QCHECK_COUNT" "5" in 300 | let (Test cell) = QCheck.(Test.make int (fun _ -> true)) in 301 | let actual = QCheck.Test.get_count cell in 302 | Alcotest.(check int) "default count is from QCHECK_COUNT" 5 actual 303 | 304 | let test_count_0 () = test_count_n ~count:0 0 305 | 306 | let test_count_negative_fail () = 307 | try 308 | let _ = test_count_n ~count:(-1) (-1) in 309 | Alcotest.fail "A negative count in a test should fail" 310 | with 311 | | _ -> () 312 | 313 | let tests = 314 | ("Test.make ~count", Alcotest.[ 315 | test_case "make with custom count" `Quick test_count_10; 316 | test_case "make with default count" `Quick test_count_default; 317 | test_case "make with env count" `Quick test_count_env; 318 | test_case "make with 0 count" `Quick test_count_0; 319 | test_case "make with negative count should fail" 320 | `Quick test_count_negative_fail; 321 | ]) 322 | end 323 | 324 | module TestLongFactor = struct 325 | let test_long_factor_n ?long_factor expected = 326 | let (Test cell) = QCheck.(Test.make ?long_factor int (fun _ -> true)) in 327 | let msg = Printf.sprintf "QCheck.Test.make ~long_factor:%s |> long_factor = %d" 328 | (Option.fold ~none:"None" ~some:string_of_int long_factor) expected 329 | in 330 | Alcotest.(check int) msg expected (QCheck.Test.get_long_factor cell) 331 | 332 | let test_long_factor_10 () = test_long_factor_n ~long_factor:10 10 333 | 334 | let test_long_factor_default () = test_long_factor_n 1 335 | 336 | let test_long_factor_env () = 337 | let () = Unix.putenv "QCHECK_LONG_FACTOR" "5" in 338 | let (Test cell) = QCheck.(Test.make int (fun _ -> true)) in 339 | let actual = QCheck.Test.get_long_factor cell in 340 | Alcotest.(check int) "default long factor is from QCHECK_LONG_FACTOR" 5 actual 341 | 342 | let test_long_factor_0 () = test_long_factor_n ~long_factor:0 0 343 | 344 | let test_long_factor_negative_fail () = 345 | try 346 | let _ = test_long_factor_n ~long_factor:(-1) (-1) in 347 | Alcotest.fail "A negative long factor in a test should fail" 348 | with 349 | | _ -> () 350 | 351 | let tests = 352 | ("Test.make ~long_factor", Alcotest.[ 353 | test_case "make with custom long_factor" `Quick test_long_factor_10; 354 | test_case "make with default long_factor" `Quick test_long_factor_default; 355 | test_case "make with env long_factor" `Quick test_long_factor_env; 356 | test_case "make with 0 long_factor" `Quick test_long_factor_0; 357 | test_case "make with negative long_factor should fail" 358 | `Quick test_long_factor_negative_fail; 359 | ]) 360 | end 361 | 362 | let () = 363 | Alcotest.run "QCheck" 364 | [ 365 | Shrink.tests; 366 | Check_exn.tests; 367 | TestCount.tests; 368 | TestLongFactor.tests; 369 | ] 370 | -------------------------------------------------------------------------------- /test/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name QCheck_tests) 3 | (modules QCheck_tests) 4 | (libraries qcheck-core)) 5 | 6 | (library 7 | (name QCheck2_tests) 8 | (modules QCheck2_tests) 9 | (libraries qcheck-core)) 10 | 11 | (rule 12 | (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) 13 | (action (copy QCheck_expect_test.expected.ocaml5.64 QCheck_expect_test.expected))) 14 | 15 | (rule 16 | (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) 17 | (action (copy QCheck_expect_test.expected.ocaml5.32 QCheck_expect_test.expected))) 18 | 19 | (rule 20 | (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) 21 | (action (copy QCheck_expect_test.expected.ocaml4.64 QCheck_expect_test.expected))) 22 | 23 | (rule 24 | (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) 25 | (action (copy QCheck_expect_test.expected.ocaml4.32 QCheck_expect_test.expected))) 26 | 27 | ;; implicitly compared against QCheck_expect_test.expected 28 | (test 29 | (name QCheck_expect_test) 30 | (modules QCheck_expect_test) 31 | (package qcheck-core) 32 | (libraries qcheck-core qcheck-core.runner QCheck_tests) 33 | (action (run ./%{test} --no-colors -s 1234))) 34 | 35 | (rule 36 | (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) 37 | (action (copy QCheck2_expect_test.expected.ocaml5.64 QCheck2_expect_test.expected))) 38 | 39 | (rule 40 | (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) 41 | (action (copy QCheck2_expect_test.expected.ocaml5.32 QCheck2_expect_test.expected))) 42 | 43 | (rule 44 | (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) 45 | (action (copy QCheck2_expect_test.expected.ocaml4.64 QCheck2_expect_test.expected))) 46 | 47 | (rule 48 | (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) 49 | (action (copy QCheck2_expect_test.expected.ocaml4.32 QCheck2_expect_test.expected))) 50 | 51 | ;; implicitly compared against QCheck2_expect_test.expected 52 | (test 53 | (name QCheck2_expect_test) 54 | (modules QCheck2_expect_test) 55 | (package qcheck-core) 56 | (libraries qcheck-core qcheck-core.runner QCheck2_tests) 57 | (action (run ./%{test} --no-colors -s 1234))) 58 | 59 | (tests 60 | (names QCheck_unit_tests QCheck2_unit_tests) 61 | (modules QCheck_unit_tests QCheck2_unit_tests) 62 | (package qcheck-core) 63 | (libraries qcheck-core alcotest)) 64 | 65 | (executable 66 | (name shrink_benchmark) 67 | (modules shrink_benchmark) 68 | (libraries qcheck-core qcheck-core.runner QCheck_tests QCheck2_tests)) 69 | 70 | (executable 71 | (name rng_independence) 72 | (modules rng_independence) 73 | (libraries qcheck-core qcheck-core.runner)) 74 | -------------------------------------------------------------------------------- /test/core/rng_independence.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | 3 | (* 4 | From https://github.com/haskell/random/issues/25 5 | Assess splitting behaviour by generating stat tests of the form: 6 | 7 | let test_to_1 = 8 | Test.make ~count:2000 ~name:"2000 pairs in [0;1]" ~collect 9 | Gen.(pair (int_bound 1) (int_bound 1)) (fun _ -> true) 10 | *) 11 | 12 | let collect (x,y) = if x=y then "equal " else "not-equal" 13 | 14 | let gen_test i = 15 | let count = 1000 + i * 1000 in 16 | let name = Printf.sprintf "%i pairs in [0;%i] - should be around 1000" count i in 17 | Test.make ~count ~name ~collect 18 | Gen.(pair (int_bound i) (int_bound i)) (fun _ -> true) 19 | 20 | let _ = 21 | QCheck_base_runner.run_tests ~verbose:true (List.init 14 (fun i -> gen_test (i+1))) 22 | -------------------------------------------------------------------------------- /test/core/shrink_benchmark.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | 3 | (** For timing and summing run times *) 4 | let time f () = 5 | let start_time = Sys.time () in 6 | let res = f () in 7 | let end_time = Sys.time () in 8 | (end_time -. start_time,res) 9 | 10 | let sum_timing_pairs times = 11 | let sum_timings = List.fold_left (+.) 0.0 in 12 | let t1,t2 = List.split times in 13 | sum_timings t1,sum_timings t2 14 | 15 | let get_name (Test.Test cell) = Test.get_name cell 16 | 17 | 18 | (** Runners for single tests, test pairs, and test pair lists *) 19 | 20 | (* run a single test with the given seed *) 21 | let run_timed_test seed cell = 22 | let open TestResult in 23 | let rand = Random.State.make [| seed |] in 24 | (* For total attempts, count occ. of 'Shrinking' in "event protocol": 25 | Shrunk 0 - Shrinking 0.1 - Shrinking 0.2 - Shrunk 1 - Shrinking 1.1 - Shrinking 1.2 *) 26 | let shr_attempts = ref 0 in 27 | let handler _ _ e = match e with 28 | | Test.Shrinking (_,_,_) -> incr shr_attempts | _ -> () in 29 | let dur,res = time (fun () -> QCheck.Test.check_cell ~rand ~handler cell) () in 30 | let name = Test.get_name cell in 31 | let res_str,shr_c,_msg = match get_state res with 32 | | Success -> failwith (Printf.sprintf "Test %s returned unexpected Success" name) 33 | | Error {exn;_} -> failwith (Printf.sprintf "Test %s returned unexpected Error %s" name (Printexc.to_string exn)) 34 | | Failed_other {msg} -> failwith (Printf.sprintf "Test %s returned unexpected Failed_other %s" name msg) 35 | | Failed {instances} -> "fail",(List.hd instances).shrink_steps, "Failed" (* expected *) in 36 | (dur,res_str,shr_c,!shr_attempts) 37 | 38 | (* run a pair of corresponding tests with the given seed *) 39 | let run_timed_test_pair seed (Test.Test c1, Test.Test c2) = 40 | let (dur1,res_str1,shr_c1,shr_att1) = run_timed_test seed c1 in 41 | let (dur2,res_str2,shr_c2,shr_att2) = run_timed_test seed c2 in 42 | if res_str1 <> res_str2 43 | then failwith (Printf.sprintf "benchmark %s gave different errors: %s and %s" (Test.get_name c1) res_str1 res_str2) 44 | else (res_str1,(dur1,shr_c1,shr_att1),(dur2,shr_c2,shr_att2)) 45 | 46 | let non_repeatable_tests = ["big bound issue59";"ints < 209609"] 47 | 48 | (* run a list of corresponding test pairs over the given seed list *) 49 | (* and print the benchmark result to channel [ch] *) 50 | let run_timing ch seeds testpairs = 51 | let fprintf = Printf.fprintf in 52 | let multiple_runs = List.length seeds > 1 in 53 | (* print iteration header - name (48 chars) *) 54 | Printf.fprintf ch "%-48s" ""; 55 | List.iter (fun seed -> fprintf ch " iteration seed %-7i %!" seed) seeds; 56 | if multiple_runs then fprintf ch " total\n%!" else print_newline (); 57 | (* print column header - name + 38 chars per iteration *) 58 | fprintf ch "%-48s" "Shrink test name"; 59 | List.iter (fun _ -> 60 | fprintf ch " %-6s%-10s %!" "Q1/s" "#succ/#att"; 61 | fprintf ch " %-6s%-10s %!" "Q2/s" "#succ/#att") seeds; 62 | if multiple_runs then fprintf ch " %6s %6s" "Q1/s" "Q2/s"; 63 | fprintf ch "\n%!"; 64 | (* print separator *) 65 | fprintf ch "%s%!" (String.make 48 '-'); 66 | List.iter (fun _ -> fprintf ch "%s%!" (String.make 38 '-')) seeds; 67 | if multiple_runs then fprintf ch "%s%!" (String.make 16 '-'); 68 | fprintf ch "\n%!"; 69 | (* print timings for each test_pair and seed *) 70 | let times = 71 | List.map 72 | (fun ((test1,_test2) as test_pair) -> 73 | let name = get_name test1 in 74 | let max_len = 48 in 75 | fprintf ch "%-48s%!" (if String.length name 85 | let _res_str,(dur1,shr_cnt1,shr_att1),(dur2,shr_cnt2,shr_att2) = run_timed_test_pair seed test_pair in 86 | fprintf ch " %6.3f %4i/%-6i%!" dur1 shr_cnt1 shr_att1; 87 | fprintf ch " %6.3f %4i/%-6i%!" dur2 shr_cnt2 shr_att2; 88 | (dur1,dur2) 89 | ) seeds in 90 | let t1_sum,t2_sum = sum_timing_pairs times in 91 | if multiple_runs then fprintf ch " %6.3f %6.3f%!" t1_sum t2_sum; 92 | fprintf ch "\n%!"; 93 | (t1_sum,t2_sum)) 94 | testpairs in 95 | let t1_sum,t2_sum = sum_timing_pairs times in 96 | fprintf ch "%s%!" (String.make (48 + 38*List.length seeds) ' '); 97 | fprintf ch " %6.3f %6.3f\n%!" t1_sum t2_sum 98 | 99 | (* merge two corresponding lists of tests *) 100 | let rec merge_and_validate xs ys = match xs,ys with 101 | | [],[] -> [] 102 | | [],_ -> failwith "QCheck2_tests.Shrink has more tests than QCheck_tests.Shrink" 103 | | _,[] -> failwith "QCheck_tests.Shrink has more tests than QCheck2_tests.Shrink" 104 | | t1::xs,t2::ys -> 105 | if get_name t1 = get_name t2 106 | then (t1,t2) :: merge_and_validate xs ys 107 | else 108 | let msg = Printf.sprintf "Found \"%s\" and \"%s\". Are QCheck_tests.Shrink and QCheck2_tests.Shrink not in the same order?" (get_name t1) (get_name t2) in 109 | failwith msg 110 | 111 | let seeds = [1234;(*4321;*)8743;(*9876;*)6789; 112 | (*2143*) (* ouch: seed 2143 causes test "lists equal to duplication" to segfault *) 113 | ] 114 | let () = 115 | let ch = open_out "shrink_bench.log" in 116 | try 117 | merge_and_validate 118 | QCheck_tests.(Shrink.tests@Function.tests) 119 | QCheck2_tests.(Shrink.tests@Function.tests) 120 | |> run_timing ch seeds; 121 | close_out ch 122 | with e -> 123 | close_out ch; 124 | raise e 125 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (package ppx_deriving_qcheck) 3 | (names 4 | test_textual 5 | test_primitives 6 | test_qualified_names 7 | test_recursive 8 | test_tuple 9 | test_variants 10 | test_record) 11 | (libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck-core) 12 | (preprocess (pps ppxlib.metaquot ppx_deriving_qcheck))) 13 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/helpers.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | (** {1. Helpers} *) 4 | 5 | let seed = [| 42 |] 6 | 7 | let generate arb = 8 | let gen = QCheck.gen arb in 9 | Gen.generate ~n:20 ~rand:(Random.State.make seed) gen 10 | 11 | (** [test_compare msg eq arb_ref arb_cand] will arberate with the same seed 12 | [arb_ref] and [arb_cand], and test with Alcotest that both arberators 13 | arberates the same values. *) 14 | let test_compare ~msg ~eq arb_ref arb_candidate = 15 | let expected = generate arb_ref in 16 | let actual = generate arb_candidate in 17 | Alcotest.(check (list eq)) msg expected actual 18 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_primitives.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Helpers 3 | 4 | (** {1. Test primitives derivation} *) 5 | 6 | (** {2. Tests} *) 7 | 8 | type int' = int [@@deriving qcheck] 9 | 10 | let test_int () = 11 | test_compare ~msg:"int <=> deriving int" ~eq:Alcotest.int int arb_int' 12 | 13 | type unit' = unit [@@deriving qcheck] 14 | 15 | (* Pretty useless though, but, meh *) 16 | let test_unit () = 17 | test_compare ~msg:"unit <=> deriving unit" ~eq:Alcotest.unit unit arb_unit' 18 | 19 | type string' = string [@@deriving qcheck] 20 | 21 | let test_string () = 22 | test_compare ~msg:"string <=> deriving string" ~eq:Alcotest.string string arb_string' 23 | 24 | type char' = char [@@deriving qcheck] 25 | 26 | let test_char () = 27 | test_compare ~msg:"char <=> deriving char" ~eq:Alcotest.char char arb_char' 28 | 29 | type bool' = bool [@@deriving qcheck] 30 | 31 | let test_bool () = 32 | test_compare ~msg:"bool <=> deriving bool" ~eq:Alcotest.bool bool arb_bool' 33 | 34 | type float' = float [@@deriving qcheck] 35 | 36 | let test_float () = 37 | test_compare ~msg:"float <=> deriving float" ~eq:(Alcotest.float 0.) float arb_float' 38 | 39 | type int32' = int32 [@@deriving qcheck] 40 | 41 | let test_int32 () = 42 | test_compare ~msg:"int32 <=> deriving int32" ~eq:Alcotest.int32 int32 arb_int32' 43 | 44 | type int64' = int64 [@@deriving qcheck] 45 | 46 | let test_int64 () = 47 | test_compare ~msg:"int64 <=> deriving int64" ~eq:Alcotest.int64 int64 arb_int64' 48 | 49 | type 'a option' = 'a option [@@deriving qcheck] 50 | 51 | let test_option () = 52 | let zero = Gen.pure 0 in 53 | test_compare ~msg:"option <=> deriving opt" 54 | ~eq:Alcotest.(option int) 55 | (option (make zero)) (arb_option' zero) 56 | 57 | type 'a array' = 'a array [@@deriving qcheck] 58 | 59 | let test_array () = 60 | let zero = Gen.pure 0 in 61 | test_compare ~msg:"array <=> deriving array" 62 | ~eq:Alcotest.(array int) 63 | (array (make zero)) (arb_array' zero) 64 | 65 | type 'a list' = 'a list [@@deriving qcheck] 66 | 67 | let test_list () = 68 | let zero = Gen.pure 0 in 69 | test_compare ~msg:"list <=> deriving list" 70 | ~eq:Alcotest.(list int) 71 | (list (make zero)) (arb_list' zero) 72 | 73 | (** {2. Execute tests} *) 74 | 75 | let () = Alcotest.run "Test_Primitives" 76 | [("Primitives", 77 | Alcotest.[ 78 | test_case "test_int" `Quick test_int; 79 | test_case "test_unit" `Quick test_unit; 80 | test_case "test_string" `Quick test_string; 81 | test_case "test_char" `Quick test_char; 82 | test_case "test_bool" `Quick test_bool; 83 | test_case "test_float" `Quick test_float; 84 | test_case "test_int32" `Quick test_int32; 85 | test_case "test_int64" `Quick test_int64; 86 | test_case "test_option" `Quick test_option; 87 | test_case "test_array" `Quick test_array; 88 | test_case "test_list" `Quick test_list; 89 | ])] 90 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_qualified_names.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Helpers 3 | 4 | module type S = sig 5 | type t = int 6 | 7 | val gen : int QCheck.Gen.t 8 | val arb : int QCheck.arbitrary 9 | end 10 | 11 | module Q : S = struct 12 | type t = int [@@deriving qcheck] 13 | end 14 | 15 | module F (X : S) = struct 16 | type t = X.t [@@deriving qcheck] 17 | end 18 | 19 | module G = F (Q) 20 | 21 | type t = Q.t [@@deriving qcheck] 22 | 23 | type u = G.t [@@deriving qcheck] 24 | 25 | let test_module () = 26 | test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int int arb 27 | 28 | let test_functor () = 29 | test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int int arb_u 30 | 31 | (** {2. Execute tests} *) 32 | 33 | let () = Alcotest.run "Test_Qualified_names" 34 | [("Qualified names", 35 | Alcotest.[ 36 | test_case "test_module" `Quick test_module; 37 | test_case "test_functor" `Quick test_functor 38 | ])] 39 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_record.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Helpers 3 | 4 | type env = { 5 | rec_types : string list; 6 | curr_types : string list; 7 | curr_type : string 8 | } 9 | [@@deriving qcheck] 10 | 11 | let pp_env fmt {rec_types; curr_types; curr_type} = 12 | let open Format in 13 | fprintf fmt {|{ 14 | rec_types = [%a]; 15 | curr_types = [%a]; 16 | curr_type = [%s]; 17 | }|} 18 | (pp_print_list pp_print_string) rec_types 19 | (pp_print_list pp_print_string) curr_types 20 | curr_type 21 | 22 | let eq_env = Alcotest.of_pp pp_env 23 | 24 | let arb_env_ref = 25 | map (fun (rec_types, curr_types, curr_type) -> 26 | { rec_types; curr_types; curr_type }) 27 | (triple (list string) (list string) string) 28 | 29 | let test_env () = 30 | test_compare ~msg:"arb_env ref <=> deriving env" 31 | ~eq:eq_env arb_env_ref arb_env 32 | 33 | type color = Color of { red : float; green : float; blue : float } 34 | [@@deriving qcheck] 35 | 36 | let pp_color fmt (Color {red; green; blue}) = 37 | let open Format in 38 | fprintf fmt {|Color { 39 | red = %a; 40 | green = %a; 41 | blue = %a; 42 | }|} 43 | pp_print_float red 44 | pp_print_float green 45 | pp_print_float blue 46 | 47 | let eq_color = Alcotest.of_pp pp_color 48 | 49 | let arb_color_ref = 50 | map (fun (red, green, blue) -> Color {red; green; blue}) (triple float float float) 51 | 52 | let test_color () = 53 | test_compare ~msg:"arb_color ref <=> deriving color" 54 | ~eq:eq_color arb_color_ref arb_color 55 | 56 | (** {2. Execute tests} *) 57 | 58 | let () = Alcotest.run "Test_Record" 59 | [("Record", 60 | Alcotest.[ 61 | test_case "test_env" `Quick test_env; 62 | test_case "test_color" `Quick test_color; 63 | ])] 64 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_recursive.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Helpers 3 | 4 | type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree 5 | [@@deriving qcheck] 6 | 7 | let rec pp_tree pp fmt x = 8 | let open Format in 9 | match x with 10 | | Leaf -> 11 | fprintf fmt "Leaf" 12 | | Node (x, l, r) -> 13 | fprintf fmt "Node (%a, %a, %a)" 14 | pp x 15 | (pp_tree pp) l 16 | (pp_tree pp) r 17 | 18 | let eq_tree pp = Alcotest.of_pp (pp_tree pp) 19 | 20 | let arb_tree_ref gen = 21 | let open Gen in 22 | make @@ sized @@ fix (fun self -> 23 | function 24 | | 0 -> pure Leaf 25 | | n -> 26 | oneof [ 27 | pure Leaf; 28 | map3 (fun x l r -> Node (x,l,r)) gen (self (n/2)) (self (n/2)); 29 | ]) 30 | 31 | let arb_tree_candidate = arb_tree 32 | 33 | let test_tree_ref () = 34 | let gen = Gen.int in 35 | test_compare ~msg:"gen tree <=> derivation tree" 36 | ~eq:(eq_tree Format.pp_print_int) 37 | (arb_tree_ref gen) (arb_tree gen) 38 | 39 | let test_leaf = 40 | Test.make 41 | ~name:"arb_tree_sized 0 = Node (_, Leaf, Leaf)" 42 | (arb_tree_sized Gen.int 0) 43 | (function 44 | | Leaf -> true 45 | | Node (_, Leaf, Leaf) -> true 46 | | _ -> false) 47 | |> 48 | QCheck_alcotest.to_alcotest 49 | 50 | (* A slight error has been found here: 51 | If the type is named `list` then `'a list` will be derived with the 52 | QCheck generator `list` instead of the `arb_list_sized`. 53 | 54 | This could lead to a design choice: 55 | - do we allow overriding primitive types? 56 | - do we prioritize `Env.curr_types` over primitive types? 57 | *) 58 | type 'a my_list = Cons of 'a * 'a my_list | Nil 59 | [@@deriving qcheck] 60 | 61 | let rec length = function 62 | | Nil -> 0 63 | | Cons (_, xs) -> 1 + length xs 64 | 65 | let test_length = 66 | Test.make 67 | ~name:"arb_list_sized n >>= fun l -> length l <= n" 68 | small_int 69 | (fun n -> 70 | let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in 71 | length l <= n) 72 | |> 73 | QCheck_alcotest.to_alcotest 74 | 75 | let () = Alcotest.run "Test_Recursive" 76 | [("Recursive", 77 | Alcotest.[ 78 | test_case "test_tree_ref" `Quick test_tree_ref; 79 | test_leaf 80 | ])] 81 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_tuple.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | type a = char [@gen QCheck.Gen.pure 'a'] 4 | [@@deriving qcheck] 5 | 6 | type b = char [@gen QCheck.Gen.pure 'b'] 7 | [@@deriving qcheck] 8 | 9 | type c = char [@gen QCheck.Gen.pure 'c'] 10 | [@@deriving qcheck] 11 | 12 | type d = char [@gen QCheck.Gen.pure 'd'] 13 | [@@deriving qcheck] 14 | 15 | type e = char [@gen QCheck.Gen.pure 'e'] 16 | [@@deriving qcheck] 17 | 18 | type f = char [@gen QCheck.Gen.pure 'f'] 19 | [@@deriving qcheck] 20 | 21 | type g = char [@gen QCheck.Gen.pure 'g'] 22 | [@@deriving qcheck] 23 | 24 | type h = char [@gen QCheck.Gen.pure 'h'] 25 | [@@deriving qcheck] 26 | 27 | type i = char [@gen QCheck.Gen.pure 'i'] 28 | [@@deriving qcheck] 29 | 30 | type tup2 = a * b 31 | [@@deriving qcheck] 32 | 33 | type tup3 = a * b * c 34 | [@@deriving qcheck] 35 | 36 | type tup4 = a * b * c * d 37 | [@@deriving qcheck] 38 | 39 | type tup5 = a * b * c * d * e 40 | [@@deriving qcheck] 41 | 42 | type tup6 = a * b * c * d * e * f 43 | [@@deriving qcheck] 44 | 45 | type tup7 = a * b * c * d * e * f * g 46 | [@@deriving qcheck] 47 | 48 | type tup8 = a * b * c * d * e * f * g * h 49 | [@@deriving qcheck] 50 | 51 | let test_tup2 = 52 | Test.make ~count:10 53 | ~name:"forall x in ('a', 'b'): x = ('a', 'b')" 54 | (make gen_tup2) 55 | (fun x -> x = ('a', 'b')) 56 | 57 | let test_tup3 = 58 | Test.make ~count:10 59 | ~name:"forall x in ('a', 'b', 'c'): x = ('a', 'b', 'c')" 60 | (make gen_tup3) 61 | (fun x -> x = ('a', 'b', 'c')) 62 | 63 | let test_tup4 = 64 | Test.make ~count:10 65 | ~name:"forall x in ('a', 'b', 'c', 'd'): x = ('a', 'b', 'c', 'd')" 66 | (make gen_tup4) 67 | (fun x -> x = ('a', 'b', 'c', 'd')) 68 | 69 | let test_tup5 = 70 | Test.make ~count:10 71 | ~name:"forall x in ('a', 'b', 'c', 'd', 'e'): x = ('a', 'b', 'c', 'd', 'e')" 72 | (make gen_tup5) 73 | (fun x -> x = ('a', 'b', 'c', 'd', 'e')) 74 | 75 | let test_tup6 = 76 | Test.make ~count:10 77 | ~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f'): x = ('a', 'b', 'c', 'd', 'e', 'f')" 78 | (make gen_tup6) 79 | (fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f')) 80 | 81 | let test_tup7 = 82 | Test.make ~count:10 83 | ~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f', 'g'): x = ('a', 'b', 'c', 'd', 'e', 'f', 'g')" 84 | (make gen_tup7) 85 | (fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f', 'g')) 86 | 87 | let test_tup8 = 88 | Test.make ~count:10 89 | ~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h'): x = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h')" 90 | (make gen_tup8) 91 | (fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h')) 92 | 93 | let tests = [ 94 | test_tup2; 95 | test_tup3; 96 | test_tup4; 97 | test_tup5; 98 | test_tup6; 99 | test_tup7; 100 | test_tup8; 101 | ] 102 | 103 | let tests = List.map (QCheck_alcotest.to_alcotest) tests 104 | 105 | (** {2. Execute tests} *) 106 | let () = Alcotest.run "Test_Tuple" [("Tuple", tests)] 107 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck/test_variants.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Helpers 3 | 4 | (** {1. Test variants and polymorphic variants derivation} *) 5 | 6 | (** {2. Variants} *) 7 | 8 | type colors = Red | Green | Blue [@@deriving qcheck] 9 | 10 | let pp_colors fmt x = 11 | let open Format in 12 | match x with 13 | | Red -> fprintf fmt "Red" 14 | | Green -> fprintf fmt "Green" 15 | | Blue -> fprintf fmt "Blue" 16 | 17 | let eq_colors = Alcotest.of_pp pp_colors 18 | 19 | let arb = oneofl [Red; Green; Blue] 20 | 21 | let test_variants () = 22 | test_compare ~msg:"Gen.oneofl <=> deriving variants" ~eq:eq_colors arb arb_colors 23 | 24 | type poly_colors = [`Red | `Green | `Blue] [@@deriving qcheck] 25 | 26 | let pp_poly_colors fmt x = 27 | let open Format in 28 | match x with 29 | | `Red -> fprintf fmt "`Red" 30 | | `Green -> fprintf fmt "`Green" 31 | | `Blue -> fprintf fmt "`Blue" 32 | 33 | let eq_poly_colors = Alcotest.of_pp pp_poly_colors 34 | 35 | let arb_poly = oneofl [`Red; `Green; `Blue] 36 | 37 | let test_poly_variants () = 38 | test_compare ~msg:"Gen.oneofl <=> deriving variants" 39 | ~eq:eq_poly_colors arb_poly arb_poly_colors 40 | 41 | (** {2. Tests weight} *) 42 | 43 | type letters = 44 | | A [@weight 0] 45 | | B 46 | [@@deriving qcheck] 47 | 48 | let test_weight = 49 | Test.make ~name:"arb_letters always produces B" 50 | arb_letters 51 | (function 52 | | A -> false 53 | | B -> true) 54 | |> 55 | QCheck_alcotest.to_alcotest 56 | 57 | type poly_letters = [ 58 | | `A [@weight 0] 59 | | `B 60 | ] 61 | [@@deriving qcheck] 62 | 63 | let test_weight_poly = 64 | Test.make ~name:"arb_poly_letters always produces B" 65 | arb_poly_letters 66 | (function 67 | | `A -> false 68 | | `B -> true) 69 | |> 70 | QCheck_alcotest.to_alcotest 71 | 72 | (** {2. Execute tests} *) 73 | 74 | let () = Alcotest.run "Test_Variant" 75 | [("Variants", 76 | Alcotest.[ 77 | test_case "test_variants" `Quick test_variants; 78 | test_case "test_poly_variants" `Quick test_poly_variants; 79 | test_weight; 80 | test_weight_poly 81 | ])] 82 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (package ppx_deriving_qcheck) 3 | (names 4 | test_textual 5 | test_primitives 6 | test_qualified_names 7 | test_recursive 8 | test_tuple 9 | test_variants 10 | test_mutual 11 | test_record) 12 | (libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck-core) 13 | (preprocess (pps ppxlib.metaquot ppx_deriving_qcheck))) 14 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/helpers.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | 3 | (** {1. Helpers} *) 4 | 5 | let seed = [| 42 |] 6 | 7 | let generate gen = Gen.generate ~n:20 ~rand:(Random.State.make seed) gen 8 | 9 | (** [test_compare msg eq gen_ref gen_cand] will generate with the same seed 10 | [gen_ref] and [gen_cand], and test with Alcotest that both generators 11 | generates the same values. *) 12 | let test_compare ~msg ~eq gen_ref gen_candidate = 13 | let expected = generate gen_ref in 14 | let actual = generate gen_candidate in 15 | Alcotest.(check (list eq)) msg expected actual 16 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_mutual.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | open Helpers 3 | 4 | type tree = Leaf | Node of tree * tree 5 | and name = { a: tree } 6 | [@@deriving qcheck2] 7 | 8 | let rec pp_tree fmt x = 9 | let open Format in 10 | match x with 11 | | Leaf -> 12 | fprintf fmt "Leaf" 13 | | Node (l, r) -> 14 | fprintf fmt "Node (%a, %a)" 15 | (pp_tree ) l 16 | (pp_tree ) r 17 | 18 | let eq_tree = Alcotest.of_pp (pp_tree ) 19 | 20 | let gen_tree_ref = 21 | let open Gen in 22 | sized @@ fix (fun self -> 23 | function 24 | | 0 -> pure Leaf 25 | | n -> 26 | oneof [ 27 | pure Leaf; 28 | map2 (fun l r -> Node (l,r)) (self (n/2)) (self (n/2)); 29 | ]) 30 | 31 | let test_tree_ref () = 32 | 33 | test_compare ~msg:"gen tree <=> derivation tree" 34 | ~eq:(eq_tree ) 35 | (gen_tree_ref) (gen_tree ) 36 | 37 | let test_leaf = 38 | Test.make 39 | ~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)" 40 | (gen_tree_sized 0) 41 | (function 42 | | Leaf -> true 43 | | Node (Leaf, Leaf) -> true 44 | | _ -> false) 45 | |> 46 | QCheck_alcotest.to_alcotest 47 | 48 | 49 | let () = Alcotest.run "Test_Recursive" 50 | [("Recursive", 51 | Alcotest.[ 52 | test_case "test_tree_ref" `Quick test_tree_ref; 53 | 54 | ])] 55 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_primitives.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | open Helpers 3 | 4 | (** {1. Test primitives derivation} *) 5 | 6 | (** {2. Tests} *) 7 | 8 | type int' = int [@@deriving qcheck2] 9 | 10 | let test_int () = 11 | test_compare ~msg:"Gen.int <=> deriving int" ~eq:Alcotest.int Gen.int gen_int' 12 | 13 | type unit' = unit [@@deriving qcheck2] 14 | 15 | (* Pretty useless though, but, meh *) 16 | let test_unit () = 17 | test_compare ~msg:"Gen.unit <=> deriving unit" ~eq:Alcotest.unit Gen.unit gen_unit' 18 | 19 | type string' = string [@@deriving qcheck2] 20 | 21 | let test_string () = 22 | test_compare ~msg:"Gen.string <=> deriving string" ~eq:Alcotest.string Gen.string gen_string' 23 | 24 | type char' = char [@@deriving qcheck2] 25 | 26 | let test_char () = 27 | test_compare ~msg:"Gen.char <=> deriving char" ~eq:Alcotest.char Gen.char gen_char' 28 | 29 | type bool' = bool [@@deriving qcheck2] 30 | 31 | let test_bool () = 32 | test_compare ~msg:"Gen.bool <=> deriving bool" ~eq:Alcotest.bool Gen.bool gen_bool' 33 | 34 | type float' = float [@@deriving qcheck2] 35 | 36 | let test_float () = 37 | test_compare ~msg:"Gen.float <=> deriving float" ~eq:(Alcotest.float 0.) Gen.float gen_float' 38 | 39 | type int32' = int32 [@@deriving qcheck2] 40 | 41 | let test_int32 () = 42 | test_compare ~msg:"Gen.int32 <=> deriving int32" ~eq:Alcotest.int32 Gen.ui32 gen_int32' 43 | 44 | type int64' = int64 [@@deriving qcheck2] 45 | 46 | let test_int64 () = 47 | test_compare ~msg:"Gen.int64 <=> deriving int64" ~eq:Alcotest.int64 Gen.ui64 gen_int64' 48 | 49 | type 'a option' = 'a option [@@deriving qcheck2] 50 | 51 | let test_option () = 52 | let zero = Gen.pure 0 in 53 | test_compare ~msg:"Gen.opt <=> deriving opt" 54 | ~eq:Alcotest.(option int) 55 | (Gen.opt zero) (gen_option' zero) 56 | 57 | type 'a array' = 'a array [@@deriving qcheck2] 58 | 59 | let test_array () = 60 | let zero = Gen.pure 0 in 61 | test_compare ~msg:"Gen.array <=> deriving array" 62 | ~eq:Alcotest.(array int) 63 | (Gen.array zero) (gen_array' zero) 64 | 65 | type 'a list' = 'a list [@@deriving qcheck2] 66 | 67 | let test_list () = 68 | let zero = Gen.pure 0 in 69 | test_compare ~msg:"Gen.list <=> deriving list" 70 | ~eq:Alcotest.(list int) 71 | (Gen.list zero) (gen_list' zero) 72 | 73 | (** {2. Execute tests} *) 74 | 75 | let () = Alcotest.run "Test_Primitives" 76 | [("Primitives", 77 | Alcotest.[ 78 | test_case "test_int" `Quick test_int; 79 | test_case "test_unit" `Quick test_unit; 80 | test_case "test_string" `Quick test_string; 81 | test_case "test_char" `Quick test_char; 82 | test_case "test_bool" `Quick test_bool; 83 | test_case "test_float" `Quick test_float; 84 | test_case "test_int32" `Quick test_int32; 85 | test_case "test_int64" `Quick test_int64; 86 | test_case "test_option" `Quick test_option; 87 | test_case "test_array" `Quick test_array; 88 | test_case "test_list" `Quick test_list; 89 | ])] 90 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_qualified_names.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | open Helpers 3 | 4 | module type S = sig 5 | type t = int 6 | 7 | val gen : int QCheck2.Gen.t 8 | end 9 | 10 | module Q : S = struct 11 | type t = int [@@deriving qcheck2] 12 | end 13 | 14 | module F (X : S) = struct 15 | type t = X.t [@@deriving qcheck2] 16 | end 17 | 18 | module G = F (Q) 19 | 20 | type t = Q.t [@@deriving qcheck2] 21 | 22 | type u = G.t [@@deriving qcheck2] 23 | 24 | let test_module () = 25 | test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int Gen.int gen 26 | 27 | let test_functor () = 28 | test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int Gen.int gen_u 29 | 30 | (** {2. Execute tests} *) 31 | 32 | let () = Alcotest.run "Test_Qualified_names" 33 | [("Qualified names", 34 | Alcotest.[ 35 | test_case "test_module" `Quick test_module; 36 | test_case "test_functor" `Quick test_functor 37 | ])] 38 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_record.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | rec_types : string list; 3 | curr_types : string list; 4 | curr_type : string 5 | } 6 | [@@deriving qcheck2] 7 | 8 | type color = Color of { red : float; green : float; blue : float } 9 | [@@deriving qcheck2] 10 | 11 | (* TODO: use these types to test generated values inside records. 12 | For now, having these ensure the compilation *) 13 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_recursive.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | open Helpers 3 | 4 | type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree 5 | [@@deriving qcheck2] 6 | 7 | let rec pp_tree pp fmt x = 8 | let open Format in 9 | match x with 10 | | Leaf -> 11 | fprintf fmt "Leaf" 12 | | Node (x, l, r) -> 13 | fprintf fmt "Node (%a, %a, %a)" 14 | pp x 15 | (pp_tree pp) l 16 | (pp_tree pp) r 17 | 18 | let eq_tree pp = Alcotest.of_pp (pp_tree pp) 19 | 20 | let gen_tree_ref gen = 21 | let open Gen in 22 | sized @@ fix (fun self -> 23 | function 24 | | 0 -> pure Leaf 25 | | n -> 26 | oneof [ 27 | pure Leaf; 28 | map3 (fun x l r -> Node (x,l,r)) gen (self (n/2)) (self (n/2)); 29 | ]) 30 | 31 | let test_tree_ref () = 32 | let gen = Gen.int in 33 | test_compare ~msg:"gen tree <=> derivation tree" 34 | ~eq:(eq_tree Format.pp_print_int) 35 | (gen_tree_ref gen) (gen_tree gen) 36 | 37 | let test_leaf = 38 | Test.make 39 | ~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)" 40 | (gen_tree_sized Gen.int 0) 41 | (function 42 | | Leaf -> true 43 | | Node (_, Leaf, Leaf) -> true 44 | | _ -> false) 45 | |> 46 | QCheck_alcotest.to_alcotest 47 | 48 | (* A slight error has been found here: 49 | If the type is named `list` then `'a list` will be derived with the 50 | QCheck generator `list` instead of the `gen_list_sized`. 51 | 52 | This could lead to a design choice: 53 | - do we allow overriding primitive types? 54 | - do we prioritize `Env.curr_types` over primitive types? 55 | *) 56 | type 'a my_list = Cons of 'a * 'a my_list | Nil 57 | [@@deriving qcheck2] 58 | 59 | let rec length = function 60 | | Nil -> 0 61 | | Cons (_, xs) -> 1 + length xs 62 | 63 | let test_length = 64 | Test.make 65 | ~name:"gen_list_sized n >>= fun l -> length l <= n" 66 | Gen.small_int 67 | (fun n -> 68 | let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in 69 | length l <= n) 70 | |> 71 | QCheck_alcotest.to_alcotest 72 | 73 | let () = Alcotest.run "Test_Recursive" 74 | [("Recursive", 75 | Alcotest.[ 76 | test_case "test_tree_ref" `Quick test_tree_ref; 77 | test_leaf 78 | ])] 79 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_tuple.ml: -------------------------------------------------------------------------------- 1 | type tup2 = int * int 2 | [@@deriving qcheck2] 3 | 4 | type tup3 = int * int * int 5 | [@@deriving qcheck2] 6 | 7 | type tup4 = int * int * int * int 8 | [@@deriving qcheck2] 9 | 10 | type tup5 = int * int * int * int * int 11 | [@@deriving qcheck2] 12 | 13 | type tup6 = int * int * int * int * int * int 14 | [@@deriving qcheck2] 15 | 16 | type tup7 = int * int * int * int * int * int * int 17 | [@@deriving qcheck2] 18 | 19 | type tup8 = int * int * int * int * int * int * int * int 20 | [@@deriving qcheck2] 21 | 22 | (* TODO: use these types to test generated values inside tuples. 23 | For now, having these ensure the compilation *) 24 | -------------------------------------------------------------------------------- /test/ppx_deriving_qcheck/deriver/qcheck2/test_variants.ml: -------------------------------------------------------------------------------- 1 | open QCheck2 2 | open Helpers 3 | 4 | (** {1. Test variants and polymorphic variants derivation} *) 5 | 6 | (** {2. Variants} *) 7 | 8 | type colors = Red | Green | Blue [@@deriving qcheck2] 9 | 10 | let pp_colors fmt x = 11 | let open Format in 12 | match x with 13 | | Red -> fprintf fmt "Red" 14 | | Green -> fprintf fmt "Green" 15 | | Blue -> fprintf fmt "Blue" 16 | 17 | let eq_colors = Alcotest.of_pp pp_colors 18 | 19 | let gen = Gen.(frequency [1,pure Red; 1,pure Green; 1,pure Blue]) 20 | 21 | let test_variants () = 22 | test_compare ~msg:"Gen.oneofl <=> deriving variants" ~eq:eq_colors gen gen_colors 23 | 24 | type poly_colors = [`Red | `Green | `Blue] [@@deriving qcheck2] 25 | 26 | let pp_poly_colors fmt x = 27 | let open Format in 28 | match x with 29 | | `Red -> fprintf fmt "`Red" 30 | | `Green -> fprintf fmt "`Green" 31 | | `Blue -> fprintf fmt "`Blue" 32 | 33 | let eq_poly_colors = Alcotest.of_pp pp_poly_colors 34 | 35 | let gen_poly : poly_colors Gen.t = Gen.(frequency [1,pure `Red; 1,pure `Green; 1,pure `Blue]) 36 | 37 | let test_poly_variants () = 38 | test_compare ~msg:"Gen.oneofl <=> deriving variants" 39 | ~eq:eq_poly_colors gen_poly gen_poly_colors 40 | 41 | (** {2. Tests weight} *) 42 | 43 | type letters = 44 | | A [@weight 0] 45 | | B 46 | [@@deriving qcheck2] 47 | 48 | let test_weight = 49 | Test.make ~name:"gen_letters always produces B" 50 | gen_letters 51 | (function 52 | | A -> false 53 | | B -> true) 54 | |> 55 | QCheck_alcotest.to_alcotest 56 | 57 | type poly_letters = [ 58 | | `A [@weight 0] 59 | | `B 60 | ] 61 | [@@deriving qcheck2] 62 | 63 | let test_weight_poly = 64 | Test.make ~name:"gen_poly_letters always produces B" 65 | gen_poly_letters 66 | (function 67 | | `A -> false 68 | | `B -> true) 69 | |> 70 | QCheck_alcotest.to_alcotest 71 | 72 | (** {2. Execute tests} *) 73 | 74 | let () = Alcotest.run "Test_Variant" 75 | [("Variants", 76 | Alcotest.[ 77 | test_case "test_variants" `Quick test_variants; 78 | test_case "test_poly_variants" `Quick test_poly_variants; 79 | test_weight; 80 | test_weight_poly 81 | ])] 82 | --------------------------------------------------------------------------------