├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── config ├── dune ├── inline_test_config.ml └── inline_test_config.mli ├── drop ├── dune └── ppx_inline_test_drop.ml ├── dune ├── dune-project ├── example ├── dune ├── example.ml ├── example.mli ├── example_type_error.mdx └── ppx_inline_test_example_lib.ml ├── libname ├── dune ├── ppx_inline_test_libname.ml └── ppx_inline_test_libname.mli ├── ppx_inline_test.opam ├── runner ├── dune ├── lib │ ├── am_testing.c │ ├── dune │ ├── ppx_inline_test_runner_lib.ml │ ├── runtime.js │ └── runtime.wat ├── ppx_inline_test_runner.ml └── ppx_inline_test_runner.mli ├── runtime-lib ├── dune ├── ppx_inline_test_lib.ml └── ppx_inline_test_lib.mli ├── src ├── dune ├── ppx_inline_test.ml └── ppx_inline_test.mli └── test ├── config.ml ├── config.mli ├── disabled.ml ├── disabled.mli ├── drop ├── drop.ml ├── drop.mli ├── dune └── ppx_inline_test_lib_drop_test.ml ├── dune ├── errors.mlt ├── failures.ml ├── failures.mli ├── file_without_test_module.ml ├── file_without_test_module.mli ├── let_test_module ├── dune ├── let_test_module.ml ├── let_test_module.mli ├── ppx_inline_test_lib_let_test_module_test.ml └── test.expected ├── only-initialize-once ├── dune ├── setup.sh ├── sub │ ├── dune │ ├── ppx_inline_test_only_initialize_once.ml │ ├── sample-client │ │ ├── dune │ │ └── inline_tests_sample_client.ml │ └── test.ml ├── test-access-settings-after-init.t └── test-only-initialize-once.t ├── order.ml ├── order.mli ├── performance_test.ml ├── performance_test.mli ├── ppx_inline_test_lib_test.ml ├── random_state.ml ├── random_state.mli ├── run-by-partition ├── dune ├── setup.sh ├── sub │ ├── dune │ ├── ppx_inline_test_run_by_partition.ml │ └── test.ml └── test-run-by-partition.t ├── test-inlining.expected ├── test.expected ├── unidiomatic_syntax.ml └── unidiomatic_syntax.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | 3 | * Added `Ppx_inline_test_lib.init`, which re-configures the test runner with a new set of arguments, rather than those from the command line. 4 | 5 | 6 | ## Release v0.16.0 7 | 8 | - Renamed `Ppx_inline_test_runner.Runtime` to `Ppx_inline_test_runner` 9 | - Renamed `Ppx_inline_test_runner.Runtime.am_running_inline_test{,_env_var}` to `Ppx_inline_test_runner.am_running{,_env_var}` 10 | - New tag `let%test _ [@tags "disabled"]` for tests that shouldn't run by default 11 | - Make the README state how to pass flags to the inline tests runner in jbuild/dune files 12 | - A bit of progress towards supporting running tests in parallel with dune (from @hhugo) 13 | 14 | ## Old pre-v0.15 changelogs (very likely stale and incomplete) 15 | 16 | ## v0.13.1 17 | 18 | - Honor the `inline_tests` Dune variable so that inline tests are 19 | dropped in release builds 20 | 21 | ## v0.11 22 | 23 | - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and 24 | ppx\_metaquot. 25 | 26 | ## 113.33.03 27 | 28 | - Changed the runtime API to make it easier to build test runners: 29 | replace the `Runtime.Test_result.record` system by 30 | `Runtime.add_evaluator` 31 | 32 | - Tell the build system via output metadata whether a file contains 33 | tests or not 34 | 35 | ## 113.33.00 36 | 37 | - Allow to configure hooks for inline tests by redefining a module 38 | Inline\_test\_config. 39 | 40 | ## 113.24.00 41 | 42 | - Support literate-style .ml files that allow ocaml code interleaved with expected output 43 | annotations. Compiling with the `ppx_expect_test` generates a program that outputs the 44 | original source file, but with the actual output substituted for the expected-output 45 | annotations. Then we can pat-diff the original file against the output file. 46 | 47 | Testing 48 | ------- 49 | Examples in the test/ and example/ folders. 50 | 51 | - Expect-tests can now be written inline in libraries by using `let%expect_test`. 52 | 53 | The runtime library has been split into two components: the test runner, which 54 | collects the output of the test body, and registers enough information to 55 | construct the `*.ml.corrected` file from the input; and the test evaluator, 56 | which compares the test output against the expected output and generates the 57 | output files. 58 | 59 | - Update to follow `Ppx_core` evolution. 60 | 61 | - When an exception is raised inside a `let%test_module`, display the position 62 | and name of the TEST\_MODULE, same as for the `let%test`. 63 | 64 | - Mark attributes as handled inside explicitly dropped pieces of code. 65 | 66 | So that a `@@deriving` inside a let%test dropped by 67 | `ppx_inline_test_drop` doesn't cause a failure. 68 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2015--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_inline_test 2 | =============== 3 | 4 | 5 | Syntax extension for writing in-line tests in ocaml code. 6 | 7 | New syntactic constructs 8 | ------------------------ 9 | 10 | The following constructs are now valid structure items: 11 | 12 | ```ocaml 13 | let%test "name" = (* true means ok, false or exn means broken *) 14 | let%test_unit "name" = (* () means ok, exn means broken *) 15 | module%test Name = (* to group tests, e.g. to share setup *) 16 | module%test [@name "name"] _ = (* more flexible naming *) 17 | let%test_module "name" = (module ) (* legacy module syntax *) 18 | ``` 19 | 20 | We may write `_` instead of `"name"` for anonymous tests. It is also possible to use 21 | `[%name ]` for a dynamically computed name. 22 | 23 | 24 | When running tests, they will be executed when the control flow reaches the structure item 25 | (i.e. at toplevel for a toplevel test; when the functor is applied for a test defined in 26 | the body of a functor, etc.). 27 | 28 | Tags 29 | ---- 30 | One can tag tests with the following construct: 31 | 32 | ```ocaml 33 | let%test "name" [@tags "no-js"] = 34 | let%test "name" [@tags "no-js", "other-tag"] = 35 | let%test _ [@tags "no-js"] = 36 | let%test _ [@tags "js-only"] = 37 | ``` 38 | 39 | Available tags are: 40 | 41 | * `no-js` for tests that should not run when compiling OCaml to Javascript 42 | 43 | * `js-only` for tests that should only run in Javascript 44 | 45 | * `32-bits-only` for tests that should only run in 32 bits architectures 46 | 47 | * `64-bits-only` for tests that should only run in 64 bits architectures 48 | 49 | * `fast-flambda` for tests that might only pass when compiling with flambda or 50 | flambda2, -O3, and cross library inlining 51 | 52 | * `fast-flambda2` for tests that might only pass when compiling with flambda2, -O3, 53 | and cross library inlining 54 | 55 | * `x-library-inlining-sensitive` for tests that might only pass when compiling 56 | with cross library inlining switched on 57 | 58 | * `disabled` for tests that should not run (unless requested with -require-tag) 59 | 60 | * `runtime4-only` for tests that should not run when compiling with runtime5 61 | 62 | * `runtime5-only` for tests that should only run when compiling with runtime5 63 | 64 | One can also tag entire test modules similarly: 65 | 66 | ```ocaml 67 | module%test Name [@tags "no-js"] = struct end 68 | ``` 69 | 70 | The flags `-drop-tag` and `-require-tag` can be passed to the test runner to restrict 71 | which tests are run. We say the tags of a test are the union of the tags applied directly 72 | to that test using `[@tags ...]` and the tags of all enclosing modules. It is to this 73 | union that the predicates `-drop-tag` and `-require-tag` are applied. 74 | 75 | If it is clear, from a test-module's tags, that none of the tests within will possibly 76 | match the tag predicates imposed by the command line flags, then additionally the 77 | top-level of that module will not be run. 78 | 79 | Examples 80 | -------- 81 | 82 | ### prime.ml 83 | 84 | ```ocaml 85 | let is_prime = 86 | 87 | let%test _ = is_prime 5 88 | let%test _ = is_prime 7 89 | let%test _ = not (is_prime 1) 90 | let%test _ = not (is_prime 8) 91 | ``` 92 | 93 | ### Tests in a functor. 94 | 95 | ```ocaml 96 | module Make(C : S) = struct 97 | 98 | let%test _ = 99 | end 100 | 101 | module M = Make(Int) 102 | ``` 103 | 104 | ### Grouping test and side-effecting initialisation. 105 | 106 | Since the module defined under `module%test` is only initialised when we 107 | run the tests, it is ok to perform side-effects in the module-expression argument. 108 | 109 | ```ocaml 110 | module%test _ = struct 111 | module UID = Unique_id.Int(struct end) 112 | 113 | let%test _ = UID.create() <> UID.create() 114 | end 115 | ``` 116 | 117 | 118 | 119 | Building and running the tests with Dune 120 | ---------------------------------------- 121 | 122 | Inline tests can only be used in libraries, not executables. 123 | 124 | To use this with dune, see [dune's documentation](https://dune.readthedocs.io/en/latest/tests.html). 125 | At the time of writing of the current document, the short version is: 126 | * define a library this way: 127 | ```lisp 128 | (library 129 | (name foo) 130 | (inline_tests) 131 | (preprocess (pps ppx_inline_test))) 132 | ``` 133 | * add tests to it 134 | * call `dune runtest` 135 | 136 | Building and running the tests without Dune 137 | ---------------------------------------- 138 | 139 | Code using this extension must be compiled and linked using the 140 | `ppx_inline_test.runtime-lib` library. The `ppx_inline_test` syntax extension will reject 141 | any test if it wasn't passed a `-inline-test-lib libname` flag. 142 | 143 | #### Execution 144 | 145 | Tests are only executed when both these conditions are met: 146 | 147 | - the executable containing the tests is linked with `ppx_inline_test.runner.lib` 148 | - the executable containing the tests is called with command line arguments: 149 | 150 | your.exe inline-test-runner libname [options] 151 | 152 | This `libname` is a way of restricting the tests run by the executable. The dependencies 153 | of your library (or executable) could also use `ppx_inline_test`, but you don't 154 | necessarily want to run their tests too. For instance, `core` is built by giving 155 | `-inline-test-lib core` and `core_extended` is built by giving `-inline-test-lib 156 | core_extended`. And now when an executable linked with both `core` and `core_extended` is 157 | run with a `libname` of `core_extended`, only the tests of `core_extended` are run. 158 | 159 | Finally, after running tests, `Ppx_inline_test_lib.exit ()` should be called (to 160 | exit with an error and a summary of the number of failed tests if there were errors or 161 | exit normally otherwise). 162 | 163 | One can construct a dual-use binary that only runs the tests when prompted to (through the 164 | command line), by sticking the following piece of code in it, after the tests have run but 165 | before the binary starts doing non-test side effects. However be aware that 166 | `Base.am_testing` will be `true` even when not running tests, which may be undesirable. 167 | 168 | ```ocaml 169 | match Ppx_inline_test_lib.testing with 170 | | `Testing `Am_test_runner -> 171 | print_endline "Exiting test suite"; 172 | Ppx_inline_test_lib.exit () 173 | | `Testing _ -> exit 0 174 | | `Not_testing -> () 175 | ``` 176 | 177 | Command line arguments 178 | ---------------------- 179 | 180 | The executable that runs tests can take additional command line arguments. The most useful 181 | of these are: 182 | 183 | * `-stop-on-error` 184 | 185 | Stop running tests after the first error. 186 | 187 | * `-verbose` 188 | 189 | to see the tests as they run 190 | 191 | * `-only-test location` 192 | 193 | where location is either a filename `-only-test main.ml`, a filename 194 | with a line number `-only-test main.ml:32`, or with the syntax that the 195 | compiler uses: `File "main.ml"`, or `File "main.ml", line 32` or `File "main.ml", 196 | line 32, characters 2-6` (characters are ignored). 197 | The position that matters is the position of the `let%test` or `let%test_unit`. 198 | 199 | The positions shown by `-verbose` are valid inputs for `-only-test`. 200 | 201 | If no `-only-test` flag is given, all the tests are 202 | run. Otherwise all the tests matching any of the locations are run. 203 | 204 | * `-drop-tag tag` 205 | 206 | drop all the tests tagged with `tag`. 207 | 208 | These can be specified to jenga like this: 209 | 210 | ``` 211 | (library 212 | (... 213 | (inline_tests ((flags (-stop-on-error)))) 214 | ... 215 | )) 216 | ``` 217 | 218 | and to dune like this: 219 | 220 | ``` 221 | (library 222 | ... 223 | (inline_tests (flags (-stop-on-error))) 224 | ...) 225 | ``` 226 | 227 | Parallelizing tests 228 | ------------------- 229 | 230 | If you pass arguments of the form `-inline-test-lib lib:partition` to `ppx_inline_test`, 231 | then you will be able to run tests from a given source file in parallel with tests from 232 | other source files. All the tests inside the same source file are still run sequentially. 233 | 234 | You should pick different `partition` names for the different files in your library (the 235 | name of the .ml files for instance). 236 | 237 | `ppx_inline_test_lib` currently requires some external system like a build system to run 238 | it multiple times in parallel, although we may make it possible to run the inline tests in 239 | parallel directly in the future. 240 | 241 | If you do that, you can now use two new flags of the executable containing the tests: 242 | 243 | * `-list-partitions` 244 | 245 | lists all the partitions that contain at least one test, one per line. 246 | 247 | * `-partition P` 248 | 249 | only run the tests of the library that are encountered at toplevel of the source file 250 | that was preprocessed with the given partition `P` (the tests need not be 251 | syntactically in the file, they could be the result of applying a functor) 252 | 253 | A build system can combine these two commands by first listing partitions, and then 254 | running one command for each partition. 255 | -------------------------------------------------------------------------------- /config/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name inline_test_config) 3 | (public_name ppx_inline_test.config) 4 | (libraries) 5 | (preprocess no_preprocessing)) 6 | -------------------------------------------------------------------------------- /config/inline_test_config.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val pre_test_hook : unit -> unit 3 | end 4 | 5 | let pre_test_hook = ignore 6 | -------------------------------------------------------------------------------- /config/inline_test_config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration for running inline tests *) 2 | 3 | (** To configure inline_test, add the following at the top of your .ml file, or in some 4 | import.ml: 5 | 6 | {[ 7 | module Inline_test_config = struct 8 | include Inline_test_config 9 | let pre_test_hook () = ... 10 | end 11 | ]} *) 12 | 13 | module type S = sig 14 | (** Run this function at the beginning of any test *) 15 | val pre_test_hook : unit -> unit 16 | end 17 | 18 | include S 19 | -------------------------------------------------------------------------------- /drop/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_drop) 3 | (public_name ppx_inline_test.drop) 4 | (kind ppx_rewriter) 5 | (libraries ppx_inline_test) 6 | (preprocess no_preprocessing)) 7 | -------------------------------------------------------------------------------- /drop/ppx_inline_test_drop.ml: -------------------------------------------------------------------------------- 1 | let () = Ppx_inline_test.set_default_maybe_drop Drop 2 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_inline_test/96920feca27e28dba1cfbdde6cec065194b09c11/dune -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_example_lib) 3 | (libraries core core_unix) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /example/example.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | module Unix = Core_unix 4 | 5 | module type S = sig 6 | type t 7 | 8 | val zero : t 9 | val succ : t -> t 10 | end 11 | 12 | module type Cnt = sig 13 | type t 14 | 15 | val _incr : unit -> t 16 | end 17 | 18 | module Cnt (V : S) : Cnt with type t = V.t = struct 19 | type t = V.t 20 | 21 | let p = ref V.zero 22 | 23 | let _incr () = 24 | p := V.succ !p; 25 | !p 26 | ;; 27 | 28 | let%test _ = V.succ V.zero > V.zero 29 | end 30 | 31 | module _ = Cnt (Int) 32 | module%test _ = Cnt (Int) 33 | module%test [@name "description"] _ = Cnt (Int) 34 | 35 | module%test _ = struct 36 | open List 37 | 38 | let%test _ = group [] ~break:(fun _ -> assert false) = [] 39 | let mis = [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] 40 | 41 | let equal_letters = 42 | [ [ 'M' ] 43 | ; [ 'i' ] 44 | ; [ 's'; 's' ] 45 | ; [ 'i' ] 46 | ; [ 's'; 's' ] 47 | ; [ 'i' ] 48 | ; [ 'p'; 'p' ] 49 | ; [ 'i' ] 50 | ] 51 | ;; 52 | 53 | let single_letters = [ [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] ] 54 | 55 | let every_three = 56 | [ [ 'M'; 'i'; 's' ]; [ 's'; 'i'; 's' ]; [ 's'; 'i'; 'p' ]; [ 'p'; 'i' ] ] 57 | ;; 58 | 59 | let%test _ = group ~break:( <> ) mis = equal_letters 60 | let%test _ = group ~break:(fun _ _ -> false) mis = single_letters 61 | let%test _ = groupi ~break:(fun i _ _ -> i mod 3 = 0) mis = every_three 62 | 63 | let%test "slow, but takes no cpu time" = 64 | ignore (Unix.nanosleep 0.25 : float); 65 | true 66 | ;; 67 | end 68 | -------------------------------------------------------------------------------- /example/example.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | -------------------------------------------------------------------------------- /example/example_type_error.mdx: -------------------------------------------------------------------------------- 1 | At time of writing, using doc comments on a test module results in an error telling the 2 | user to remove the comment. 3 | 4 | ```ocaml 5 | (* Non-doc comment *) 6 | 7 | (** wow *) 8 | module%test _ = struct 9 | let%expect_test _ = return () 10 | end 11 | ``` 12 | ```mdx-error 13 | Line 3, characters 3-13: 14 | Error: Attributes not allowed here 15 | ``` 16 | -------------------------------------------------------------------------------- /example/ppx_inline_test_example_lib.ml: -------------------------------------------------------------------------------- 1 | module Example = Example 2 | -------------------------------------------------------------------------------- /libname/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_libname) 3 | (public_name ppx_inline_test.libname) 4 | (libraries ppxlib) 5 | (preprocess no_preprocessing)) 6 | -------------------------------------------------------------------------------- /libname/ppx_inline_test_libname.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let libname_and_partition = ref None 4 | 5 | let () = 6 | Driver.add_arg 7 | "-inline-test-lib" 8 | (Arg.String 9 | (fun lib -> 10 | let p = 11 | match String.index lib ':' with 12 | | exception Not_found -> lib, None 13 | | i -> 14 | String.sub lib 0 i, Some (String.sub lib (i + 1) (String.length lib - i - 1)) 15 | in 16 | libname_and_partition := Some p)) 17 | ~doc: 18 | " A base name to use for generated identifiers (has to be globally unique in a \ 19 | program). ppx_inline_test (and ppx_bench) are disabled unless this flag is \ 20 | passed." 21 | ;; 22 | 23 | let () = 24 | Driver.Cookies.add_simple_handler 25 | "library-name" 26 | Ast_pattern.(estring __) 27 | ~f:(function 28 | | None -> () 29 | | Some lib -> libname_and_partition := Some (lib, None)) 30 | ;; 31 | 32 | let get () = !libname_and_partition 33 | -------------------------------------------------------------------------------- /libname/ppx_inline_test_libname.mli: -------------------------------------------------------------------------------- 1 | (** This library defines the command line argument -inline-test-lib (and ppxlib cookie 2 | library-name), shared by both ppx_bench and ppx_inline_test. *) 3 | val get : unit -> (string * string option) option 4 | -------------------------------------------------------------------------------- /ppx_inline_test.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ppx_inline_test" 5 | bug-reports: "https://github.com/janestreet/ppx_inline_test/issues" 6 | dev-repo: "git+https://github.com/janestreet/ppx_inline_test.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_inline_test/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "base" 15 | "sexplib0" 16 | "time_now" 17 | "dune" {>= "3.17.0"} 18 | "ppxlib" {>= "0.33.0" & < "0.36.0"} 19 | ] 20 | available: arch != "arm32" & arch != "x86_32" 21 | synopsis: "Syntax extension for writing in-line tests in ocaml code" 22 | description: " 23 | Part of the Jane Street's PPX rewriters collection. 24 | " 25 | -------------------------------------------------------------------------------- /runner/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_runner) 3 | (public_name ppx_inline_test.runner) 4 | (libraries ppx_inline_test_lib ppx_inline_test_runner_lib) 5 | (library_flags -linkall) 6 | (preprocess no_preprocessing)) 7 | -------------------------------------------------------------------------------- /runner/lib/am_testing.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | CAMLprim value Base_am_testing() { return Val_true; } 4 | -------------------------------------------------------------------------------- /runner/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (foreign_stubs 3 | (language c) 4 | (names am_testing)) 5 | (name ppx_inline_test_runner_lib) 6 | (public_name ppx_inline_test.runner.lib) 7 | (js_of_ocaml 8 | (flags --no-sourcemap) 9 | (javascript_files runtime.js)) 10 | (libraries base) 11 | (preprocess no_preprocessing) 12 | (wasm_of_ocaml 13 | (flags --no-sourcemap) 14 | (javascript_files runtime.js) 15 | (wasm_files runtime.wat))) 16 | -------------------------------------------------------------------------------- /runner/lib/ppx_inline_test_runner_lib.ml: -------------------------------------------------------------------------------- 1 | (*_ This autogenerated file is empty because there were no modules 2 | in this library when it was generated. *) 3 | -------------------------------------------------------------------------------- /runner/lib/runtime.js: -------------------------------------------------------------------------------- 1 | //Provides: Base_am_testing const 2 | function Base_am_testing(x) { 3 | return 1 4 | } 5 | -------------------------------------------------------------------------------- /runner/lib/runtime.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (import "env" "Base_am_testing_flag" 3 | (global $Base_am_testing_flag (mut i32))) 4 | 5 | (func $set_am_testing 6 | (global.set $Base_am_testing_flag (i32.const 1))) 7 | 8 | (start $set_am_testing) 9 | ) 10 | -------------------------------------------------------------------------------- /runner/ppx_inline_test_runner.ml: -------------------------------------------------------------------------------- 1 | let () = Ppx_inline_test_lib.exit () 2 | -------------------------------------------------------------------------------- /runner/ppx_inline_test_runner.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /runtime-lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_lib) 3 | (public_name ppx_inline_test.runtime-lib) 4 | (libraries base inline_test_config sexplib0 time_now) 5 | (preprocess no_preprocessing)) 6 | -------------------------------------------------------------------------------- /runtime-lib/ppx_inline_test_lib.ml: -------------------------------------------------------------------------------- 1 | module Test_result = struct 2 | type t = 3 | | Success 4 | | Failure 5 | | Error 6 | 7 | let to_exit_code = function 8 | | Success -> 0 9 | | Failure -> 2 10 | | Error -> 1 11 | ;; 12 | 13 | let to_string = function 14 | | Success -> "success" 15 | | Failure -> "failure" 16 | | Error -> "error" 17 | ;; 18 | 19 | let combine t1 t2 = 20 | match t1, t2 with 21 | | Success, Success -> Success 22 | | Error, _ | _, Error -> Error 23 | | Failure, _ | _, Failure -> Failure 24 | ;; 25 | 26 | let combine_all ts = List.fold_left combine Success ts 27 | end 28 | 29 | type descr = string 30 | 31 | let already_initialized = ref false 32 | let test_modules_ran = ref 0 33 | let test_modules_failed = ref 0 34 | let tests_ran = ref 0 35 | let tests_failed = ref 0 36 | let dynamic_lib : string option ref = ref None 37 | 38 | type filename = string 39 | type line_number = int 40 | type start_pos = int 41 | type end_pos = int 42 | type config = (module Inline_test_config.S) 43 | 44 | type 'a test_function_args = 45 | config:config 46 | -> descr:descr Lazy.t 47 | -> tags:string list 48 | -> filename:filename 49 | -> line_number:line_number 50 | -> start_pos:start_pos 51 | -> end_pos:end_pos 52 | -> 'a 53 | 54 | module Tag_predicate = struct 55 | type t = 56 | { required_tags : string list 57 | ; dropped_tags : string list 58 | } 59 | 60 | let initial = { required_tags = []; dropped_tags = [ "disabled" ] } 61 | 62 | let drop t tag = 63 | { dropped_tags = tag :: t.dropped_tags 64 | ; required_tags = List.filter (( <> ) tag) t.required_tags 65 | } 66 | ;; 67 | 68 | let require t tag = 69 | { dropped_tags = List.filter (( <> ) tag) t.dropped_tags 70 | ; required_tags = tag :: t.required_tags 71 | } 72 | ;; 73 | 74 | let entire_module_disabled t ~partial_tags:tags = 75 | List.exists (fun dropped -> List.mem dropped tags) t.dropped_tags 76 | ;; 77 | 78 | let disabled t ~complete_tags:tags = 79 | List.exists (fun req -> not (List.mem req tags)) t.required_tags 80 | || List.exists (fun dropped -> List.mem dropped tags) t.dropped_tags 81 | ;; 82 | end 83 | 84 | module Where_to_list = struct 85 | type t = 86 | | Stdout 87 | | File of string 88 | end 89 | 90 | type which_tests = 91 | { libname : string 92 | ; only_test_location : (filename * line_number option * bool ref) list 93 | ; name_filter : string list 94 | ; which_tags : Tag_predicate.t 95 | } 96 | 97 | type test_mode = 98 | { which_tests : which_tests 99 | ; what_to_do : [ `Run_partition of string option | `List_partitions of Where_to_list.t ] 100 | } 101 | 102 | let force_drop = 103 | try 104 | ignore (Sys.getenv "FORCE_DROP_INLINE_TEST" : string); 105 | true 106 | with 107 | | Not_found -> false 108 | ;; 109 | 110 | module Action : sig 111 | type t = 112 | [ `Ignore 113 | | `Test_mode of test_mode 114 | ] 115 | 116 | val get : unit -> t 117 | val set : t -> unit 118 | end = struct 119 | type t = 120 | [ `Ignore 121 | | `Test_mode of test_mode 122 | ] 123 | 124 | let action : t ref = ref `Ignore 125 | 126 | let get () = 127 | (* This is useful when compiling to javascript. 128 | Js_of_ocaml can statically evaluate [Sys.getenv "FORCE_DROP_INLINE_TEST"] 129 | and inline the result ([`Ignore]) whenever [get ()] is called. 130 | Unit tests can then be treated as deadcode since the argument [f] of the [test] 131 | function below is never used. *) 132 | if force_drop then `Ignore else !action 133 | ;; 134 | 135 | let set v = action := v 136 | end 137 | 138 | module Partition : sig 139 | val found_test : unit -> unit 140 | val set_current : string -> unit 141 | val is_current : string option -> bool 142 | val all : unit -> string list 143 | end = struct 144 | let all = Hashtbl.create 23 145 | let current = ref "" 146 | let set_current x = current := x 147 | 148 | let found_test () = 149 | if !current <> "" && not (Hashtbl.mem all !current) then Hashtbl.add all !current () 150 | ;; 151 | 152 | let is_current = function 153 | | None -> true 154 | | Some p -> p = !current 155 | ;; 156 | 157 | let all () = List.sort String.compare (Hashtbl.fold (fun k () acc -> k :: acc) all []) 158 | end 159 | 160 | module Module_context = struct 161 | module T = struct 162 | type one_module = 163 | { descr : string 164 | ; tags : string list 165 | } 166 | 167 | type t = one_module list 168 | 169 | let descr t = List.map (fun m -> m.descr) t 170 | let tags t = List.concat (List.map (fun m -> m.tags) t) 171 | end 172 | 173 | let current : T.t ref = ref [] 174 | 175 | let with_ ~descr ~tags f = 176 | let prev = !current in 177 | current := { T.descr; tags } :: prev; 178 | try 179 | let x = f () in 180 | current := prev; 181 | x 182 | with 183 | | e -> 184 | current := prev; 185 | raise e 186 | ;; 187 | 188 | let current_descr () = T.descr !current 189 | let current_tags () = T.tags !current 190 | end 191 | 192 | let verbose_output_channel = ref None 193 | let strict = ref false 194 | let show_counts = ref false 195 | let list_test_names = ref false 196 | let delayed_errors = ref [] 197 | let stop_on_error = ref false 198 | let log = ref None 199 | let time_sec = ref 0. 200 | let use_color = ref true 201 | let in_place = ref false 202 | let diff_command = ref None 203 | let source_tree_root = ref None 204 | let diff_path_prefix = ref None 205 | 206 | let opt_printf ch fmt = 207 | let formatter = 208 | match ch with 209 | | None -> Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) 210 | | Some ch -> Format.formatter_of_out_channel ch 211 | in 212 | Format.fprintf formatter fmt 213 | ;; 214 | 215 | let displayed_descr descr filename line start_pos end_pos = 216 | let (lazy descr) = descr in 217 | Printf.sprintf 218 | "File %S, line %d, characters %d-%d%s" 219 | filename 220 | line 221 | start_pos 222 | end_pos 223 | (if descr = "" then "" else ": " ^ descr) 224 | ;; 225 | 226 | let parse_descr str = 227 | try 228 | Some 229 | (Scanf.sscanf 230 | str 231 | " File %S , line %d , characters %d - %d %!" 232 | (fun file line _start_pos _end_pos -> file, Some line)) 233 | with 234 | | _ -> 235 | (try 236 | Some (Scanf.sscanf str " File %S , line %d %!" (fun file line -> file, Some line)) 237 | with 238 | | _ -> 239 | (try Some (Scanf.sscanf str " File %S %!" (fun file -> file, None)) with 240 | | _ -> None)) 241 | ;; 242 | 243 | let parse_argv ?current args = 244 | match args with 245 | | name 246 | :: "inline-test-runner" (* when we see this argument, we switch to test mode *) 247 | :: lib 248 | :: rest -> 249 | (* initialization should only occur once *) 250 | if !already_initialized 251 | then 252 | raise 253 | (Arg.Bad 254 | "The inline test runner can only be initialized once, and has already been \ 255 | initialized."); 256 | already_initialized := true; 257 | let tests = ref [] in 258 | let list_partitions = (ref None : Where_to_list.t option ref) in 259 | let partition = ref None in 260 | let tag_predicate = ref Tag_predicate.initial in 261 | let name_filter = ref [] in 262 | Arg.parse_argv 263 | ?current 264 | (Array.of_list (name :: rest)) 265 | (Arg.align 266 | [ ( "-list-test-names" 267 | , Arg.Unit 268 | (fun () -> 269 | list_test_names := true; 270 | verbose_output_channel := Some stdout) 271 | , " Do not run tests but show what would have been run" ) 272 | ; ( "-list-partitions" 273 | , Arg.Unit (fun () -> list_partitions := Some Stdout) 274 | , " Lists all the partitions that contain at least one test or test_module" ) 275 | ; ( "-list-partitions-into-file" 276 | , Arg.String (fun file -> list_partitions := Some (File file)) 277 | , " Lists all the partitions that contain at least one test or test_module \ 278 | into FILE" ) 279 | ; ( "-partition" 280 | , Arg.String (fun i -> partition := Some i) 281 | , " Only run the tests in the given partition" ) 282 | ; ( "-verbose" 283 | , Arg.Unit (fun () -> verbose_output_channel := Some stdout) 284 | , " Show the tests as they run" ) 285 | ; ( "-verbose-to-stderr" 286 | , Arg.Unit (fun () -> verbose_output_channel := Some stderr) 287 | , " Show the tests on stderr as they run" ) 288 | ; ( "-stop-on-error" 289 | , Arg.Set stop_on_error 290 | , " Run tests only up to the first error (doesn't work for expect tests)" ) 291 | ; "-strict", Arg.Set strict, " End with an error if no tests were run" 292 | ; "-show-counts", Arg.Set show_counts, " Show the number of tests ran" 293 | ; ( "-log" 294 | , Arg.Unit 295 | (fun () -> 296 | (try Sys.remove "inline_tests.log" with 297 | | _ -> ()); 298 | log := Some (open_out "inline_tests.log")) 299 | , " Log the tests run in inline_tests.log" ) 300 | ; ( "-drop-tag" 301 | , Arg.String (fun s -> tag_predicate := Tag_predicate.drop !tag_predicate s) 302 | , "tag Only run tests not tagged with [tag] (overrides previous -require-tag)" 303 | ) 304 | ; ( "-require-tag" 305 | , Arg.String (fun s -> tag_predicate := Tag_predicate.require !tag_predicate s) 306 | , "tag Only run tests tagged with [tag] (overrides previous -drop-tag)" ) 307 | ; ( "-matching" 308 | , Arg.String (fun s -> name_filter := s :: !name_filter) 309 | , "substring Only run tests whose names contain the given substring" ) 310 | ; ( "-only-test" 311 | , Arg.String 312 | (fun s -> 313 | let filename, index = 314 | match parse_descr s with 315 | | Some (file, index) -> file, index 316 | | None -> 317 | if String.contains s ':' 318 | then ( 319 | let i = String.index s ':' in 320 | let filename = String.sub s 0 i in 321 | let index_string = 322 | String.sub s (i + 1) (String.length s - i - 1) 323 | in 324 | let index = 325 | try int_of_string index_string with 326 | | Failure _ -> 327 | raise 328 | (Arg.Bad 329 | (Printf.sprintf 330 | "Argument %s doesn't fit the format \ 331 | filename[:line_number]\n\ 332 | %!" 333 | s)) 334 | in 335 | filename, Some index) 336 | else s, None 337 | in 338 | tests := (filename, index, ref false) :: !tests) 339 | , "location Run only the tests specified by all the -only-test options.\n\ 340 | \ Locations can be one of these forms:\n\ 341 | \ - file.ml\n\ 342 | \ - file.ml:line_number\n\ 343 | \ - File \"file.ml\"\n\ 344 | \ - File \"file.ml\", line 23\n\ 345 | \ - File \"file.ml\", line 23, characters 2-3" ) 346 | ; "-no-color", Arg.Clear use_color, " Summarize tests without using color" 347 | ; "-in-place", Arg.Set in_place, " Update expect tests in place" 348 | ; ( "-diff-cmd" 349 | , Arg.String (fun s -> diff_command := Some s) 350 | , " Diff command for tests that require diffing (use - to disable diffing)" ) 351 | ; ( "-source-tree-root" 352 | , Arg.String (fun s -> source_tree_root := Some s) 353 | , " Path to the root of the source tree" ) 354 | ; ( "-diff-path-prefix" 355 | , Arg.String (fun s -> diff_path_prefix := Some s) 356 | , " Prefix to prepend to filepaths in test output" ) 357 | ]) 358 | (fun anon -> 359 | raise 360 | (Arg.Bad (Printf.sprintf "%s: unexpected anonymous argument %s\n%!" name anon))) 361 | (Printf.sprintf "%s %s %s [args]" name "inline-test-runner" lib); 362 | Action.set 363 | (`Test_mode 364 | { which_tests = 365 | { libname = lib 366 | ; only_test_location = !tests 367 | ; which_tags = !tag_predicate 368 | ; name_filter = !name_filter 369 | } 370 | ; what_to_do = 371 | (match !list_partitions with 372 | | Some where_to_list -> `List_partitions where_to_list 373 | | None -> `Run_partition !partition) 374 | }) 375 | | _ -> () 376 | ;; 377 | 378 | let () = 379 | if Base.Exported_for_specific_uses.am_testing 380 | then ( 381 | try parse_argv (Array.to_list Sys.argv) with 382 | | Arg.Bad msg -> 383 | Printf.eprintf "%s" msg; 384 | exit 1 385 | | Arg.Help msg -> 386 | Printf.printf "%s" msg; 387 | exit 0) 388 | ;; 389 | 390 | let init args = 391 | let current = ref 0 in 392 | try 393 | parse_argv ~current args; 394 | Ok None 395 | with 396 | | Arg.Bad msg -> Error msg 397 | | Arg.Help msg -> Ok (Some msg) 398 | ;; 399 | 400 | let am_test_runner = 401 | match Action.get () with 402 | | `Test_mode _ -> true 403 | | `Ignore -> false 404 | ;; 405 | 406 | let am_running_env_var = 407 | (* for approximate compatibility, given that the variable is not exactly equivalent 408 | to what PPX_INLINE_TEST_LIB_AM_RUNNING_INLINE_TEST used to be *) 409 | "TESTING_FRAMEWORK" 410 | ;; 411 | 412 | (* This value is deprecated in principle, in favor of Core.am_running_test, so 413 | we're going to live with the ugly pattern match. *) 414 | let am_running = 415 | match Sys.getenv "PPX_INLINE_TEST_LIB_AM_RUNNING_INLINE_TEST" with 416 | | (_ : string) -> 417 | true (* for compatibility with people setting this variable directly *) 418 | | exception Not_found -> 419 | (match Sys.getenv am_running_env_var with 420 | | "inline-test" -> true 421 | | exception Not_found -> false 422 | | _ -> false) 423 | ;; 424 | 425 | let testing = 426 | if am_test_runner 427 | then `Testing `Am_test_runner 428 | else if am_running 429 | then `Testing `Am_child_of_test_runner 430 | else `Not_testing 431 | ;; 432 | 433 | (* This function returns an int63 representing the number of nanos since 434 | some (fixed) baseline. On unix, this baseline will be the unix epoch, 435 | and in javascript, the baseline will be "program initialization time." 436 | Regardless, it's always safe to subtract two values and use the diff, 437 | which is all that ppx_inline_test_lib uses it for. *) 438 | let timestamp_ns () = Time_now.nanosecond_counter_for_timing () 439 | 440 | let where_to_cut_backtrace = 441 | lazy 442 | (Base.String.Search_pattern.create 443 | (__MODULE__ ^ "." ^ "time_without_resetting_random_seeds")) 444 | ;; 445 | 446 | let time_without_resetting_random_seeds f = 447 | let before_ns = timestamp_ns () in 448 | let res = 449 | (* To avoid noise in backtraces, we do two things. 450 | 451 | We use [where_to_cut_backtrace] above to remove the stack frames for the current 452 | function and any function it gets inlined into, as it's not of any interest to the 453 | user, since it's not talking about their test but instead talking about the 454 | ppx_inline_test machinery. 455 | 456 | We also avoid inserting any code between the [f] that comes from the user's file 457 | and grabbing the backtrace from its exceptions (no wrapping of [f] with high order 458 | functions like Exn.protect, or (fun () -> f (); true)). *) 459 | try Ok (f ()) with 460 | | exn -> Error (exn, Printexc.get_backtrace ()) 461 | in 462 | time_sec := Base.Int63.(timestamp_ns () - before_ns |> to_float) /. 1e9; 463 | res 464 | ;; 465 | 466 | let saved_caml_random_state = lazy (Stdlib.Random.State.make [| 100; 200; 300 |]) 467 | let saved_base_random_state = lazy (Base.Random.State.make [| 111; 222; 333 |]) 468 | 469 | let time_and_reset_random_seeds f = 470 | let caml_random_state = Stdlib.Random.get_state () in 471 | let base_random_state = Base.Random.State.copy Base.Random.State.default in 472 | Stdlib.Random.set_state (Lazy.force saved_caml_random_state); 473 | Base.Random.set_state (Lazy.force saved_base_random_state); 474 | let result = time_without_resetting_random_seeds f in 475 | Stdlib.Random.set_state caml_random_state; 476 | Base.Random.set_state base_random_state; 477 | result 478 | ;; 479 | 480 | let string_of_module_descr () = 481 | String.concat 482 | "" 483 | (List.map 484 | (fun s -> " in TES" ^ "T_MODULE at " ^ String.uncapitalize_ascii s ^ "\n") 485 | (Module_context.current_descr ())) 486 | ;; 487 | 488 | let position_match def_filename def_line_number l = 489 | List.exists 490 | (fun (filename, line_number_opt, used) -> 491 | let position_start = String.length def_filename - String.length filename in 492 | let found = 493 | position_start >= 0 494 | && 495 | let end_of_def_filename = 496 | String.sub def_filename position_start (String.length filename) 497 | in 498 | end_of_def_filename = filename 499 | && (position_start = 0 || def_filename.[position_start - 1] = '/') 500 | && 501 | match line_number_opt with 502 | | None -> true 503 | | Some line_number -> def_line_number = line_number 504 | in 505 | if found then used := true; 506 | found) 507 | l 508 | ;; 509 | 510 | let name_filter_match ~name_filter descr = 511 | match name_filter with 512 | | [] -> true 513 | | _ :: _ -> 514 | List.exists (fun substring -> Base.String.is_substring ~substring descr) name_filter 515 | ;; 516 | 517 | let print_delayed_errors () = 518 | match List.rev !delayed_errors with 519 | | [] -> () 520 | | _ :: _ as delayed_errors -> 521 | Printf.eprintf "\n%s\n%!" (String.make 70 '='); 522 | List.iter (fun message -> Printf.eprintf "%s%!" message) delayed_errors 523 | ;; 524 | 525 | let eprintf_or_delay fmt = 526 | Printf.ksprintf 527 | (fun s -> 528 | (match !verbose_output_channel with 529 | | Some _ -> delayed_errors := s :: !delayed_errors 530 | | None -> Printf.eprintf "%s%!" s); 531 | if !stop_on_error 532 | then ( 533 | print_delayed_errors (); 534 | exit 2)) 535 | fmt 536 | ;; 537 | 538 | let add_hooks ((module C) : config) f () = 539 | C.pre_test_hook (); 540 | f () 541 | ;; 542 | 543 | let hum_backtrace backtrace = 544 | let open Base in 545 | backtrace 546 | |> String.split_lines 547 | |> List.take_while ~f:(fun str -> 548 | not (String.Search_pattern.matches (force where_to_cut_backtrace) str)) 549 | |> List.map ~f:(fun str -> " " ^ str ^ "\n") 550 | |> String.concat 551 | ;; 552 | 553 | let[@inline never] test_inner 554 | ~config 555 | ~descr 556 | ~tags 557 | ~filename:def_filename 558 | ~line_number:def_line_number 559 | ~start_pos 560 | ~end_pos 561 | f 562 | bool_of_f 563 | = 564 | match Action.get () with 565 | | `Ignore -> () 566 | | `Test_mode 567 | { which_tests = { libname; only_test_location; which_tags; name_filter } 568 | ; what_to_do 569 | } -> 570 | let f = add_hooks config f in 571 | let descr = 572 | lazy (displayed_descr descr def_filename def_line_number start_pos end_pos) 573 | in 574 | let complete_tags = tags @ Module_context.current_tags () in 575 | let should_run = 576 | Some libname = !dynamic_lib 577 | && (match only_test_location with 578 | | [] -> true 579 | | _ :: _ -> position_match def_filename def_line_number only_test_location) 580 | && (not (Tag_predicate.disabled which_tags ~complete_tags)) 581 | && name_filter_match ~name_filter (Lazy.force descr) 582 | in 583 | if should_run 584 | then ( 585 | match what_to_do with 586 | | `List_partitions _ -> Partition.found_test () 587 | | `Run_partition partition -> 588 | if Partition.is_current partition 589 | then ( 590 | let descr = Lazy.force descr in 591 | incr tests_ran; 592 | opt_printf !log "%s\n%s" descr (string_of_module_descr ()); 593 | opt_printf !verbose_output_channel "%s%!" descr; 594 | let result = 595 | if !list_test_names 596 | then Ok true 597 | else 598 | (* See [time_without_resetting_random_seeds] for why we use [bool_of_f] 599 | rather have the caller wrap [f] to adjust its return value. *) 600 | Result.map bool_of_f (time_and_reset_random_seeds f) 601 | in 602 | (* If !list_test_names, this is is a harmless zero. *) 603 | opt_printf !verbose_output_channel " (%.3f sec)\n%!" !time_sec; 604 | match result with 605 | | Ok true -> () 606 | | Ok false -> 607 | incr tests_failed; 608 | eprintf_or_delay "%s is false.\n%s\n%!" descr (string_of_module_descr ()) 609 | | Error (exn, backtrace) -> 610 | incr tests_failed; 611 | let backtrace = hum_backtrace backtrace in 612 | let exn_str = Sexplib0.Sexp_conv.printexc_prefer_sexp exn in 613 | let sep = if String.contains exn_str '\n' then "\n" else " " in 614 | eprintf_or_delay 615 | "%s threw%s%s.\n%s%s\n%!" 616 | descr 617 | sep 618 | exn_str 619 | backtrace 620 | (string_of_module_descr ()))) 621 | ;; 622 | 623 | let set_lib_and_partition static_lib partition = 624 | match !dynamic_lib with 625 | | Some _ -> 626 | (* possible if the interface is used explicitly or if we happen to dynlink something 627 | that contain tests *) 628 | () 629 | | None -> 630 | dynamic_lib := Some static_lib; 631 | (match Action.get () with 632 | | `Ignore -> () 633 | | `Test_mode { which_tests; what_to_do } -> 634 | if which_tests.libname = static_lib 635 | then ( 636 | let requires_partition = 637 | match what_to_do with 638 | | `List_partitions _ | `Run_partition (Some _) -> true 639 | | `Run_partition None -> false 640 | in 641 | if partition = "" && requires_partition 642 | then 643 | failwith 644 | "ppx_inline_test: cannot use -list-partition or -partition without \ 645 | specifying a partition at preprocessing time" 646 | else Partition.set_current partition)) 647 | ;; 648 | 649 | let unset_lib static_lib = 650 | match !dynamic_lib with 651 | | None -> 652 | (* not giving an error, because when some annoying people put pa_ounit in their list 653 | of preprocessors, pa_ounit is set up twice and we have two calls to unset_lib at 654 | the end of the file, and the second one comes in this branch *) 655 | () 656 | | Some lib -> if lib = static_lib then dynamic_lib := None 657 | ;; 658 | 659 | let test ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f = 660 | test_inner ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f (fun b -> 661 | b) 662 | ;; 663 | 664 | let test_unit ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f = 665 | test_inner ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f (fun () -> 666 | true) 667 | ;; 668 | 669 | let[@inline never] test_module 670 | ~config 671 | ~descr 672 | ~tags 673 | ~filename:def_filename 674 | ~line_number:def_line_number 675 | ~start_pos 676 | ~end_pos 677 | f 678 | = 679 | match Action.get () with 680 | | `Ignore -> () 681 | | `Test_mode 682 | { which_tests = { libname; only_test_location = _; name_filter = _; which_tags } 683 | ; what_to_do 684 | } -> 685 | let f = add_hooks config f in 686 | let descr () = displayed_descr descr def_filename def_line_number start_pos end_pos in 687 | let partial_tags = tags @ Module_context.current_tags () in 688 | let should_run = 689 | Some libname = !dynamic_lib 690 | (* If, no matter what tags a test defines, we certainly will drop all tests within 691 | this module, then don't run the module at all. This means people can write 692 | things like the following without breaking the 32-bit build: 693 | module%test [@tags "64-bits-only"] _ = struct 694 | let i = Int64.to_int_exn .... 695 | end 696 | We don't shortcut based on position, as we can't tell what positions the 697 | inner tests will have. *) 698 | && not (Tag_predicate.entire_module_disabled which_tags ~partial_tags) 699 | in 700 | if should_run 701 | then ( 702 | match what_to_do with 703 | | `List_partitions _ -> Partition.found_test () 704 | | `Run_partition partition -> 705 | if Partition.is_current partition 706 | then ( 707 | incr test_modules_ran; 708 | let descr = descr () in 709 | match 710 | Module_context.with_ ~descr ~tags (fun () -> 711 | (* We do not reset random states upon entering [module%test]. 712 | 713 | Con: Code in test modules can accidentally depend on top-level random 714 | state effects. 715 | 716 | Pros: (1) We don't reset to the same seed on entering a [module%test] 717 | and then a [let%test] inside that module, which could lead to 718 | accidentally randomly generating the same values in some test. (2) Moving 719 | code into and out of [module%test] does not change its random seed. 720 | *) 721 | time_without_resetting_random_seeds f) 722 | with 723 | | Ok () -> () 724 | | Error (exn, backtrace) -> 725 | incr test_modules_failed; 726 | let backtrace = hum_backtrace backtrace in 727 | let exn_str = Sexplib0.Sexp_conv.printexc_prefer_sexp exn in 728 | let sep = if String.contains exn_str '\n' then "\n" else " " in 729 | eprintf_or_delay 730 | ("TES" ^^ "T_MODULE at %s threw%s%s.\n%s%s\n%!") 731 | (String.uncapitalize_ascii descr) 732 | sep 733 | exn_str 734 | backtrace 735 | (string_of_module_descr ()))) 736 | ;; 737 | 738 | let summarize () = 739 | match Action.get () with 740 | | `Ignore -> 741 | if Sys.argv <> [||] && Filename.basename Sys.argv.(0) = "inline_tests_runner.exe" 742 | then 743 | Printf.eprintf 744 | "inline_tests_runner.exe is not supposed to be run by hand, you \n\ 745 | should run the inline_tests_runner script instead.\n\ 746 | %!" 747 | else 748 | Printf.eprintf 749 | "You are doing something unexpected with the tests. No tests have \n\ 750 | been run. You should use the inline_tests_runner script to run \n\ 751 | tests.\n\ 752 | %!"; 753 | Test_result.Error 754 | | `Test_mode { which_tests = _; what_to_do = `List_partitions where_to_list } -> 755 | let with_out_channel f = 756 | match where_to_list with 757 | | Stdout -> f stdout 758 | | File file -> 759 | (* Not passing Open_creat ensures that the file we are supposed to write to exists *) 760 | open_out_gen [ Open_wronly; Open_text ] 0 file 761 | |> Base.Exn.protectx ~f ~finally:close_out 762 | in 763 | with_out_channel (fun fout -> 764 | List.iter (Printf.fprintf fout "%s\n") (Partition.all ())); 765 | Test_result.Success 766 | | `Test_mode { what_to_do = `Run_partition _; which_tests } -> 767 | (match !log with 768 | | None -> () 769 | | Some ch -> close_out ch); 770 | print_delayed_errors (); 771 | (match !tests_failed, !test_modules_failed with 772 | | 0, 0 -> 773 | if !show_counts 774 | then 775 | Printf.eprintf 776 | "%d tests ran, %d test_modules ran\n%!" 777 | !tests_ran 778 | !test_modules_ran; 779 | let errors = 780 | let unused_tests = 781 | List.filter (fun (_, _, used) -> not !used) which_tests.only_test_location 782 | in 783 | match unused_tests with 784 | | [] -> None 785 | | _ :: _ -> Some unused_tests 786 | in 787 | (match errors with 788 | | Some tests -> 789 | Printf.eprintf 790 | "ppx_inline_test error: the following -only-test flags matched nothing:"; 791 | List.iter 792 | (fun (filename, line_number_opt, _) -> 793 | match line_number_opt with 794 | | None -> Printf.eprintf " %s" filename 795 | | Some line_number -> Printf.eprintf " %s:%d" filename line_number) 796 | tests; 797 | Printf.eprintf ".\n%!"; 798 | Test_result.Error 799 | | None -> 800 | if !tests_ran = 0 && !strict 801 | then ( 802 | Printf.eprintf "ppx_inline_test error: no tests have been run.\n%!"; 803 | Test_result.Error) 804 | else Test_result.Success) 805 | | count, count_test_modules -> 806 | Printf.eprintf 807 | "FAILED %d / %d tests%s\n%!" 808 | count 809 | !tests_ran 810 | (if count_test_modules = 0 811 | then "" 812 | else Printf.sprintf (", %d TES" ^^ "T_MODULES") count_test_modules); 813 | Test_result.Failure) 814 | ;; 815 | 816 | let assert_test_configs_initialized config = 817 | if not !already_initialized 818 | then 819 | Printf.sprintf 820 | "ppx_inline_test error: attempted to access the [%s] config before [init] was \ 821 | called" 822 | config 823 | |> failwith 824 | ;; 825 | 826 | let verbose () = 827 | assert_test_configs_initialized "verbose"; 828 | Option.is_some !verbose_output_channel 829 | ;; 830 | 831 | let use_color () = 832 | assert_test_configs_initialized "use_color"; 833 | !use_color 834 | ;; 835 | 836 | let in_place () = 837 | assert_test_configs_initialized "in_place"; 838 | !in_place 839 | ;; 840 | 841 | let diff_command () = 842 | assert_test_configs_initialized "diff_command"; 843 | !diff_command 844 | ;; 845 | 846 | let diff_path_prefix () = 847 | assert_test_configs_initialized "diff_path_prefix"; 848 | !diff_path_prefix 849 | ;; 850 | 851 | let source_tree_root () = 852 | assert_test_configs_initialized "source_tree_root"; 853 | !source_tree_root 854 | ;; 855 | 856 | let evaluators = ref [ summarize ] 857 | let add_evaluator ~f = evaluators := f :: !evaluators 858 | 859 | let evaluate_exit_status () = 860 | List.map (fun f -> f ()) (List.rev !evaluators) 861 | |> Test_result.combine_all 862 | |> Test_result.to_exit_code 863 | ;; 864 | 865 | let exit () = evaluate_exit_status () |> exit 866 | -------------------------------------------------------------------------------- /runtime-lib/ppx_inline_test_lib.mli: -------------------------------------------------------------------------------- 1 | (** [am_running] is [true] if the code is running inline tests (e.g. [let%expect_test], 2 | [let%test], [let%test_unit]) or is in an executable invoked from inline tests. *) 3 | val am_running : bool 4 | 5 | val am_running_env_var : string 6 | 7 | (** [`Am_test_runner] means the [./inline_tests_runner] process, whereas 8 | [`Am_child_of_test_runner] means a process descended from the test runner. *) 9 | val testing 10 | : [ `Not_testing | `Testing of [ `Am_test_runner | `Am_child_of_test_runner ] ] 11 | 12 | (** The tests to run are configured by command line arguments, normally pulled from 13 | [Sys.argv]. Calling [init] will re-configure the test runner using the passed-in 14 | argument list. This is useful to run tests in a dynamically loaded library; this 15 | should be called with the appropriate configuration before loading the library. 16 | 17 | [init] will normally return None. It will return an error if there's a formatting 18 | error in the arguments, and will return Some string if help was requested. It will 19 | also return an error if the test runner has already initialized, either by reading 20 | command-line arguments or by a previous call to [init]. *) 21 | val init : string list -> (string option, string) result 22 | 23 | (**/**) 24 | 25 | (** Everything below is for ppx or internal use *) 26 | 27 | module Test_result : sig 28 | type t = 29 | | Success 30 | | Failure 31 | | Error 32 | 33 | val combine : t -> t -> t 34 | val combine_all : t list -> t 35 | val to_string : t -> string 36 | end 37 | 38 | type config = (module Inline_test_config.S) 39 | 40 | type 'a test_function_args = 41 | config:config 42 | -> descr:string Lazy.t 43 | -> tags:string list 44 | -> filename:string 45 | -> line_number:int 46 | -> start_pos:int 47 | -> end_pos:int 48 | -> 'a 49 | 50 | val set_lib_and_partition : string -> string -> unit 51 | val unset_lib : string -> unit 52 | val test : ((unit -> bool) -> unit) test_function_args 53 | val test_unit : ((unit -> unit) -> unit) test_function_args 54 | val test_module : ((unit -> unit) -> unit) test_function_args 55 | val verbose : unit -> bool 56 | val use_color : unit -> bool 57 | val in_place : unit -> bool 58 | val diff_command : unit -> string option 59 | val diff_path_prefix : unit -> string option 60 | val source_tree_root : unit -> string option 61 | 62 | (** This value is [true] if [FORCE_DROP_INLINE_TEST] was set at startup time. This is 63 | useful when compiling to javascript --- Js_of_ocaml can statically evaluate 64 | [Sys.getenv "FORCE_DROP_INLINE_TEST"]. Unit tests visibly only reachable if 65 | [force_drop] is [true] can then be treated as deadcode. 66 | 67 | It is guaranteed that, if [force_drop = true], no test registered via one of the 68 | [test] functions above will run. 69 | 70 | [force_drop] is only exposed so that other ppxs can generate code that checks it more 71 | in sight of JSOO's DCE. [force_drop] is otherwise not a recommended method of changing 72 | the behavior of a program based on whether test are running. *) 73 | val force_drop : bool 74 | 75 | (** Record an evaluator for an external set of tests *) 76 | val add_evaluator : f:(unit -> Test_result.t) -> unit 77 | 78 | (** Exit with a status based on the combined result of all recorded evaluators *) 79 | val exit : unit -> _ 80 | 81 | (** Like [exit], but just return the exit status that would have been used *) 82 | val evaluate_exit_status : unit -> int 83 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test) 3 | (public_name ppx_inline_test) 4 | (kind 5 | (ppx_rewriter 6 | (cookies 7 | (inline_tests %{inline_tests})))) 8 | (ppx_runtime_libraries ppx_inline_test.config ppx_inline_test.runtime-lib) 9 | (libraries base ppxlib ppx_inline_test_libname) 10 | (preprocess 11 | (pps ppxlib.metaquot)) 12 | (inline_tests.backend 13 | (runner_libraries ppx_inline_test.runner.lib) 14 | (generate_runner 15 | (echo "let () = Ppx_inline_test_lib.exit ();;")) 16 | (list_partitions_flags "inline-test-runner" %{library-name} 17 | -list-partitions) 18 | (flags "inline-test-runner" %{library-name} -partition %{partition} 19 | -source-tree-root %{workspace_root} -diff-cmd -))) 20 | -------------------------------------------------------------------------------- /src/ppx_inline_test.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | open Ast_builder.Default 4 | 5 | (* Generated code should depend on the environment in scope as little as 6 | possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the 7 | use of [=]. It is especially important to not use polymorphic comparisons, since we 8 | are moving more and more to code that doesn't have them in scope. *) 9 | 10 | type maybe_drop = 11 | | Keep 12 | | Drop_with_deadcode 13 | | Drop 14 | 15 | let maybe_drop_mode = ref Keep 16 | let set_default_maybe_drop x = maybe_drop_mode := x 17 | let allow_let_test_module = ref false 18 | let allow_let_test_module_flag = "-inline-test-allow-let-test-module" 19 | 20 | let () = 21 | Driver.add_arg 22 | "-inline-test-drop" 23 | (Unit (fun () -> maybe_drop_mode := Drop)) 24 | ~doc:" Drop unit tests"; 25 | Driver.add_arg 26 | "-inline-test-drop-with-deadcode" 27 | (Unit (fun () -> maybe_drop_mode := Drop_with_deadcode)) 28 | ~doc: 29 | " Drop unit tests by wrapping them inside deadcode to prevent unused variable \ 30 | warnings."; 31 | Driver.add_arg 32 | allow_let_test_module_flag 33 | (Set allow_let_test_module) 34 | ~doc:" Allow [let%test_module]; otherwise, require newer form [module%test]." 35 | ;; 36 | 37 | let () = 38 | Driver.Cookies.add_simple_handler 39 | "inline-test" 40 | Ast_pattern.(pexp_ident (lident __')) 41 | ~f:(function 42 | | None -> () 43 | | Some id -> 44 | (match id.txt with 45 | | "drop" -> maybe_drop_mode := Drop 46 | | "drop_with_deadcode" -> maybe_drop_mode := Drop_with_deadcode 47 | | s -> 48 | Location.raise_errorf 49 | ~loc:id.loc 50 | "invalid 'inline-test' cookie (%s), expected one of: drop, \ 51 | drop_with_deadcode" 52 | s)) 53 | ;; 54 | 55 | (* Same as above, but for the Dune setting *) 56 | let () = 57 | Driver.Cookies.add_simple_handler 58 | "inline_tests" 59 | Ast_pattern.(estring __') 60 | ~f:(function 61 | | None -> () 62 | | Some id -> 63 | (match id.txt with 64 | | "enabled" -> maybe_drop_mode := Keep 65 | | "disabled" -> maybe_drop_mode := Drop 66 | | "ignored" -> maybe_drop_mode := Drop_with_deadcode 67 | | s -> 68 | Location.raise_errorf 69 | ~loc:id.loc 70 | "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ 71 | ignored" 72 | s)) 73 | ;; 74 | 75 | let maybe_drop loc code = 76 | match !maybe_drop_mode with 77 | | Keep -> [%str let () = [%e code]] 78 | | Drop_with_deadcode -> [%str let () = if false then [%e code] else ()] 79 | | Drop -> 80 | Attribute.explicitly_drop#expression code; 81 | [%str] 82 | ;; 83 | 84 | let rec short_desc_of_expr ~max_len e = 85 | match e.pexp_desc with 86 | | Pexp_let (_, _, e) | Pexp_letmodule (_, _, e) -> short_desc_of_expr ~max_len e 87 | | _ -> 88 | let s = Pprintast.string_of_expression e in 89 | let res = 90 | if String.length s >= max_len 91 | then ( 92 | let s_short = String.sub s ~pos:0 ~len:(max_len - 5) in 93 | s_short ^ "[...]") 94 | else s 95 | in 96 | String.map res ~f:(function 97 | | '\n' -> ' ' 98 | | c -> c) 99 | ;; 100 | 101 | let descr ~(loc : Location.t) ?(inner_loc = loc) e_opt id_opt = 102 | let filename = loc.loc_start.pos_fname in 103 | let line = loc.loc_start.pos_lnum in 104 | let start_pos = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in 105 | let end_pos = inner_loc.Location.loc_end.pos_cnum - loc.loc_start.pos_bol in 106 | let descr = 107 | match id_opt with 108 | | `Literal id -> estring ~loc id 109 | | `Expr e -> e 110 | | `None -> 111 | estring 112 | ~loc 113 | (match e_opt with 114 | | None -> "" 115 | | Some e -> "<<" ^ short_desc_of_expr ~max_len:50 e ^ ">>") 116 | in 117 | ( pexp_lazy ~loc descr 118 | , estring ~loc filename 119 | , eint ~loc line 120 | , eint ~loc start_pos 121 | , eint ~loc end_pos ) 122 | ;; 123 | 124 | let apply_to_descr lid ~loc ?inner_loc e_opt id_opt tags more_arg = 125 | let descr, filename, line, start_pos, end_pos = descr ~loc ?inner_loc e_opt id_opt in 126 | let expr = 127 | pexp_apply 128 | ~loc 129 | (evar ~loc ("Ppx_inline_test_lib." ^ lid)) 130 | [ Labelled "config", [%expr (module Inline_test_config)] 131 | ; Labelled "descr", descr 132 | ; Labelled "tags", elist ~loc (List.map ~f:(estring ~loc) tags) 133 | ; Labelled "filename", filename 134 | ; Labelled "line_number", line 135 | ; Labelled "start_pos", start_pos 136 | ; Labelled "end_pos", end_pos 137 | ; Nolabel, more_arg 138 | ] 139 | in 140 | maybe_drop loc expr 141 | ;; 142 | 143 | let can_use_test_extensions () = 144 | match !maybe_drop_mode, Ppx_inline_test_libname.get () with 145 | | Keep, None -> false 146 | | (Drop | Drop_with_deadcode), _ | _, Some _ -> true 147 | ;; 148 | 149 | (* Set to [true] when we see a [let%test] or [let%expect_test] etc extension. *) 150 | module Has_tests = 151 | Driver.Create_file_property 152 | (struct 153 | let name = "ppx_inline_test.has_tests" 154 | end) 155 | (Bool) 156 | 157 | let all_tags = 158 | [ "no-js" 159 | ; "js-only" 160 | ; "no-wasm" 161 | ; "wasm-only" 162 | ; "64-bits-only" 163 | ; "32-bits-only" 164 | ; "fast-flambda" 165 | ; "fast-flambda2" 166 | ; "x-library-inlining-sensitive" 167 | ; "not-on-el7" 168 | ; "not-on-el8" 169 | ; "disabled" 170 | ; "runtime5-only" 171 | ; "runtime4-only" 172 | ] 173 | ;; 174 | 175 | let validate_tag tag = 176 | if not (List.mem all_tags tag ~equal:String.equal) 177 | then Error (Spellcheck.spellcheck all_tags tag) 178 | else Ok () 179 | ;; 180 | 181 | let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = 182 | Has_tests.set true; 183 | if not (can_use_test_extensions ()) 184 | then 185 | Location.raise_errorf 186 | ~loc 187 | "%s: extension is disabled because the tests would be ignored (the build system \ 188 | didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ 189 | writing tests in files that are part of an executable stanza, but only library \ 190 | stanzas support inline tests)" 191 | name_of_ppx_rewriter; 192 | List.iter tags ~f:(fun tag -> 193 | match validate_tag tag with 194 | | Ok () -> () 195 | | Error hint -> 196 | let hint = 197 | match hint with 198 | | None -> "" 199 | | Some hint -> "\n" ^ hint 200 | in 201 | Location.raise_errorf 202 | ~loc 203 | "%s: %S is not a valid tag for inline tests.%s" 204 | name_of_ppx_rewriter 205 | tag 206 | hint) 207 | ;; 208 | 209 | let name_of_ppx_rewriter = "ppx_inline_test" 210 | 211 | let expand_let_test ~loc ~path:_ ~name:id ~tags e = 212 | let loc = { loc with loc_ghost = true } in 213 | validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; 214 | apply_to_descr "test" ~loc (Some e) id tags [%expr fun () -> [%e e]] 215 | ;; 216 | 217 | let expand_test_unit ~loc ~path:_ ~name:id ~tags e = 218 | let loc = { loc with loc_ghost = true } in 219 | validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; 220 | (* The "; ()" bit is there to breaks tail call optimization, for better backtraces. *) 221 | apply_to_descr 222 | "test_unit" 223 | ~loc 224 | (Some e) 225 | id 226 | tags 227 | [%expr 228 | fun () -> 229 | [%e e]; 230 | ()] 231 | ;; 232 | 233 | let expand_test_module ~is_let_test_module ~loc ~path:_ ~name:id ~tags m = 234 | let loc = { loc with loc_ghost = true } in 235 | if is_let_test_module && not !allow_let_test_module 236 | then 237 | Location.raise_errorf 238 | ~loc 239 | "Convert [%s] to [%s] or pass [%s] to ppx driver" 240 | "let%test_module" 241 | "module%test" 242 | allow_let_test_module_flag; 243 | validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; 244 | apply_to_descr 245 | "test_module" 246 | ~loc 247 | ~inner_loc:m.pmod_loc 248 | None 249 | id 250 | tags 251 | (pexp_fun 252 | ~loc 253 | Nolabel 254 | None 255 | (punit ~loc) 256 | (pexp_letmodule ~loc (Located.mk ~loc (Some "M")) m (eunit ~loc))) 257 | ;; 258 | 259 | let expand_test ~loc ~path variant = 260 | match variant with 261 | | `Let (name, tags, e) -> expand_let_test ~loc ~path ~name ~tags e 262 | | `Module (name, tags, m) -> 263 | expand_test_module ~is_let_test_module:false ~loc ~path ~name ~tags m 264 | ;; 265 | 266 | module E = struct 267 | open Ast_pattern 268 | 269 | let make_tags context = 270 | Attribute.declare 271 | "tags" 272 | context 273 | (single_expr_payload 274 | (pexp_tuple (many (estring __)) ||| map (estring __) ~f:(fun f x -> f [ x ]))) 275 | (fun x -> x) 276 | ;; 277 | 278 | let pattern_tags = make_tags Attribute.Context.pattern 279 | let module_tags = make_tags Attribute.Context.module_binding 280 | 281 | let list_of_option = function 282 | | None -> [] 283 | | Some x -> x 284 | ;; 285 | 286 | let opt_name () = 287 | map (pstring __) ~f:(fun f x -> f (`Literal x)) 288 | ||| map ppat_any ~f:(fun f -> f `None) 289 | ||| map 290 | (ppat_extension 291 | (extension (cst ~to_string:Fn.id "name") (single_expr_payload __))) 292 | ~f:(fun f e -> f (`Expr e)) 293 | ;; 294 | 295 | let opt_name_and_expr expr = 296 | pstr 297 | (pstr_value 298 | nonrecursive 299 | (value_binding 300 | ~pat: 301 | (map 302 | (Attribute.pattern pattern_tags (opt_name ())) 303 | ~f:(fun f attributes name_opt -> 304 | f ~name:name_opt ~tags:(list_of_option attributes))) 305 | ~expr 306 | ^:: nil) 307 | ^:: nil) 308 | ;; 309 | 310 | let module_name_pattern pat = 311 | Ast_pattern.of_func (fun ctx loc mb k -> 312 | let name_attrs, other_attrs = 313 | List.partition_map mb.pmb_attributes ~f:(fun attr -> 314 | match attr with 315 | | { attr_name = { txt = "name"; loc = _ } 316 | ; attr_payload = 317 | PStr 318 | [%str 319 | [%e? { pexp_desc = Pexp_constant (Pconst_string (name, _, _)); _ }]] 320 | ; attr_loc = _ 321 | } -> First (attr, name) 322 | | _ -> Second attr) 323 | in 324 | match name_attrs with 325 | | [] -> Ast_pattern.to_func pat ctx loc mb (k None) 326 | | [ (attr, name) ] -> 327 | Attribute.mark_as_handled_manually attr; 328 | Ast_pattern.to_func 329 | pat 330 | ctx 331 | loc 332 | { mb with pmb_attributes = other_attrs } 333 | (k (Some name)) 334 | | _ :: _ :: _ -> Location.raise_errorf ~loc "duplicate @name attribute") 335 | ;; 336 | 337 | let module_name_and_expr expr = 338 | pstr 339 | (pstr_module 340 | (module_binding ~name:__' ~expr 341 | |> module_name_pattern 342 | |> Attribute.pattern module_tags 343 | |> map0' ~f:Fn.id 344 | |> map ~f:(fun f loc tags attr_name bind_name m -> 345 | let tags = list_of_option tags in 346 | let name = 347 | match attr_name, bind_name.txt with 348 | | None, None -> `None 349 | | Some name, None | None, Some name -> `Literal name 350 | | Some attr_name, Some bind_name -> 351 | Location.raise_errorf 352 | ~loc 353 | "multiple names; use one of:\n\ 354 | \ [module%%test %s =], or\n\ 355 | \ [module%%test [@name %S] _ =],\n\ 356 | but not both." 357 | bind_name 358 | attr_name 359 | in 360 | f ~name ~tags m)) 361 | ^:: nil) 362 | ;; 363 | 364 | let let_or_module_name_and_expr = 365 | let let_pattern = 366 | map (opt_name_and_expr __) ~f:(fun f ~name ~tags e -> f (`Let (name, tags, e))) 367 | in 368 | let module_pattern = 369 | map (module_name_and_expr __) ~f:(fun f ~name ~tags m -> 370 | f (`Module (name, tags, m))) 371 | in 372 | let_pattern ||| module_pattern 373 | ;; 374 | 375 | let test = 376 | Extension.declare_inline 377 | "inline_test.test" 378 | Extension.Context.structure_item 379 | let_or_module_name_and_expr 380 | expand_test 381 | ;; 382 | 383 | let test_unit = 384 | Extension.declare_inline 385 | "inline_test.test_unit" 386 | Extension.Context.structure_item 387 | (opt_name_and_expr __) 388 | expand_test_unit 389 | ;; 390 | 391 | let test_module = 392 | Extension.declare_inline 393 | "inline_test.test_module" 394 | Extension.Context.structure_item 395 | (opt_name_and_expr (pexp_pack __)) 396 | (expand_test_module ~is_let_test_module:true) 397 | ;; 398 | 399 | let all = [ test; test_unit; test_module ] 400 | end 401 | 402 | let tags = E.pattern_tags 403 | 404 | let () = 405 | Driver.V2.register_transformation 406 | "inline-test" 407 | ~extensions:E.all 408 | ~enclose_impl:(fun ctxt loc -> 409 | match loc, Ppx_inline_test_libname.get () with 410 | | None, _ | _, None -> [], [] 411 | | Some loc, Some (libname, partition_opt) -> 412 | let partition = 413 | match partition_opt with 414 | | None -> Stdlib.Filename.basename (Expansion_context.Base.input_name ctxt) 415 | | Some p -> p 416 | in 417 | let loc = { loc with loc_ghost = true } in 418 | (* See comment in benchmark_accumulator.ml *) 419 | let header = 420 | let loc = { loc with loc_end = loc.loc_start } in 421 | maybe_drop 422 | loc 423 | [%expr 424 | Ppx_inline_test_lib.set_lib_and_partition 425 | [%e estring ~loc libname] 426 | [%e estring ~loc partition]] 427 | and footer = 428 | let loc = { loc with loc_start = loc.loc_end } in 429 | maybe_drop loc [%expr Ppx_inline_test_lib.unset_lib [%e estring ~loc libname]] 430 | in 431 | header, footer) 432 | ;; 433 | -------------------------------------------------------------------------------- /src/ppx_inline_test.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | type maybe_drop = 4 | | Keep 5 | | Drop_with_deadcode 6 | | Drop 7 | 8 | (** How to expand tests if no "-inline-test-drop*" command line flag is passed. *) 9 | val set_default_maybe_drop : maybe_drop -> unit 10 | 11 | (** To be called on test extension points that use the ppx_inline_test runtime. Checks 12 | that tests are allowed with the given ppx command line, and that the tags are defined. *) 13 | val validate_extension_point_exn 14 | : name_of_ppx_rewriter:string 15 | -> loc:location 16 | -> tags:string list 17 | -> unit 18 | 19 | val maybe_drop : Location.t -> Parsetree.expression -> Parsetree.structure 20 | 21 | (**/**) 22 | 23 | val tags : (Parsetree.pattern, string list) Attribute.t 24 | -------------------------------------------------------------------------------- /test/config.ml: -------------------------------------------------------------------------------- 1 | module%test _ = struct 2 | let x = ref 0 3 | let init = lazy (x := 42) 4 | 5 | module Inline_test_config = struct 6 | include Inline_test_config 7 | 8 | let pre_test_hook () = Lazy.force init 9 | end 10 | 11 | let%test _ = !x = 42 12 | end 13 | -------------------------------------------------------------------------------- /test/config.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/disabled.ml: -------------------------------------------------------------------------------- 1 | (* Check that tests with the disabled tag are not run. *) 2 | 3 | let%test (_ [@tags "disabled"]) = false 4 | -------------------------------------------------------------------------------- /test/disabled.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/drop/drop.ml: -------------------------------------------------------------------------------- 1 | (* Check that ignored attributes inside dropped tests do not trigger an error *) 2 | 3 | module%test _ = struct 4 | [@@@attribute_not_handled_by_anything] 5 | end 6 | -------------------------------------------------------------------------------- /test/drop/drop.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/drop/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_lib_drop_test) 3 | (preprocess 4 | (pps ppx_inline_test_drop))) 5 | -------------------------------------------------------------------------------- /test/drop/ppx_inline_test_lib_drop_test.ml: -------------------------------------------------------------------------------- 1 | module Drop = Drop 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_lib_test) 3 | (preprocess 4 | (pps ppx_inline_test))) 5 | 6 | (alias 7 | (name test-runner-runtime-deps) 8 | (deps 9 | ./inline_tests_runner 10 | ./inline_tests_runner.exe 11 | (glob_files *.ml))) 12 | 13 | (rule 14 | (targets test.output test-partitions.output test-inlining.output) 15 | (deps 16 | (alias test-runner-runtime-deps)) 17 | (action 18 | (bash 19 | "\nfunction run {\n { OCAMLRUNPARAM=b=0 ./inline_tests_runner \"$@\" || echo code: $?; } |&\n sed -r -e '/runtime.ml/ s/[0-9]+/XXX/g' -e 's/\\([0-9.]* sec\\)/(XXX sec)/'\n}\nrun > test.output\n\n(\n export DONT_ASSUME_ALL_TESTS_RUN=\n run -list-partitions | while read p; do\n echo Test for partition $p:\n run -partition $p\n done\n) > test-partitions.output\n\n(\n export DONT_ASSUME_ALL_TESTS_RUN=\n echo Partitions diff:\n diff <(run -require-tag x-library-inlining-sensitive -list-partitions) <(run -list-partitions) || true\n echo\n run -require-tag x-library-inlining-sensitive -verbose\n) > test-inlining.output"))) 20 | 21 | (rule 22 | (targets diff-with-without-partitions) 23 | (deps ./test.output ./test-partitions.output) 24 | (action 25 | (bash 26 | "\ndiff -u --label test.output --label test-partitions.output test.output test-partitions.output > diff-with-without-partitions || true\n"))) 27 | 28 | (rule 29 | (deps test.expected test.output test-inlining.expected test-inlining.output) 30 | (action 31 | (bash 32 | "diff -u test.{expected,output}\n diff -u test-inlining.{expected,output}")) 33 | (alias runtest)) 34 | 35 | (alias 36 | (name runtest) 37 | (deps diff-with-without-partitions)) 38 | -------------------------------------------------------------------------------- /test/errors.mlt: -------------------------------------------------------------------------------- 1 | module%test [@name "only tells the truth"] Lies = struct end 2 | 3 | [%%expect 4 | {| 5 | Line _, characters _-_: 6 | Error: multiple names; use one of: 7 | [module%test Lies =], or 8 | [module%test [@name "only tells the truth"] _ =], 9 | but not both. 10 | |}] 11 | 12 | let%test_module _ = (module struct end) 13 | 14 | [%%expect 15 | {| 16 | Line _, characters _-_: 17 | Error: Convert [let%test_module] to [module%test] or pass [-inline-test-allow-let-test-module] to ppx driver 18 | |}] 19 | -------------------------------------------------------------------------------- /test/failures.ml: -------------------------------------------------------------------------------- 1 | (* Checking failures are reported properly, and make the overall 2 | test fail. *) 3 | 4 | let%test _ = false 5 | let%test "name1" = raise Exit 6 | 7 | module%test Name2 = struct 8 | let%test _ = false 9 | let%test _ = false 10 | let%test _ = raise Exit 11 | 12 | module%test [@name "name3"] _ = struct 13 | let () = raise Exit 14 | end 15 | end 16 | 17 | module%test _ = struct 18 | let () = raise Exit 19 | end 20 | 21 | let x, y = "name", "4" 22 | let%test [%name x ^ y] = false 23 | -------------------------------------------------------------------------------- /test/failures.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/file_without_test_module.ml: -------------------------------------------------------------------------------- 1 | let%test _ = true 2 | -------------------------------------------------------------------------------- /test/file_without_test_module.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/let_test_module/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_lib_let_test_module_test) 3 | (preprocess 4 | (pps ppx_inline_test -inline-test-allow-let-test-module))) 5 | 6 | (alias 7 | (name test-runner-runtime-deps) 8 | (deps 9 | ./inline_tests_runner 10 | ./inline_tests_runner.exe 11 | (glob_files *.ml))) 12 | 13 | (rule 14 | (targets test.output) 15 | (deps 16 | (alias test-runner-runtime-deps)) 17 | (action 18 | (bash 19 | "\nfunction run {\n { OCAMLRUNPARAM=b=0 ./inline_tests_runner \"$@\" || echo code: $?; } |&\n sed -r -e '/runtime.ml/ s/[0-9]+/XXX/g' -e 's/\\([0-9.]* sec\\)/(XXX sec)/'\n}\nrun > test.output\n"))) 20 | 21 | (rule 22 | (deps test.expected test.output) 23 | (action 24 | (bash "diff -u test.{expected,output}")) 25 | (alias runtest)) 26 | -------------------------------------------------------------------------------- /test/let_test_module/let_test_module.ml: -------------------------------------------------------------------------------- 1 | let%test_module _ = 2 | (module struct 3 | let%test_unit _ = if true then failwith "let percent test module did in fact run" 4 | end) 5 | ;; 6 | -------------------------------------------------------------------------------- /test/let_test_module/let_test_module.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/let_test_module/ppx_inline_test_lib_let_test_module_test.ml: -------------------------------------------------------------------------------- 1 | module Let_test_module = Let_test_module 2 | -------------------------------------------------------------------------------- /test/let_test_module/test.expected: -------------------------------------------------------------------------------- 1 | File "let_test_module.ml", line 3, characters 4-85: <> threw (Failure "let percent test module did in fact run"). 2 | in TEST_MODULE at file "let_test_module.ml", line 1, characters 0-128 3 | 4 | FAILED 1 / 1 tests 5 | code: 2 6 | -------------------------------------------------------------------------------- /test/only-initialize-once/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name test-runner-runtime-deps) 3 | (deps 4 | ./sub/inline_tests_runner 5 | ./sub/inline_tests_runner.exe 6 | (glob_files sub/*.ml))) 7 | -------------------------------------------------------------------------------- /test/only-initialize-once/setup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | TEST_DIR="$(pwd)" 3 | export TEST_DIR 4 | -------------------------------------------------------------------------------- /test/only-initialize-once/sub/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_only_initialize_once) 3 | (libraries stdio) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /test/only-initialize-once/sub/ppx_inline_test_only_initialize_once.ml: -------------------------------------------------------------------------------- 1 | module Test = Test 2 | -------------------------------------------------------------------------------- /test/only-initialize-once/sub/sample-client/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names inline_tests_sample_client) 4 | (libraries base ppx_inline_test_lib stdio) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /test/only-initialize-once/sub/sample-client/inline_tests_sample_client.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let show_init_result init_result = 4 | match init_result with 5 | | Error err -> Printf.sprintf "\n%s" err |> Stdio.print_endline 6 | | Ok init_result -> 7 | (match init_result with 8 | | None -> Stdio.print_endline "" 9 | | Some help -> Printf.sprintf "\n%s" help |> Stdio.print_endline) 10 | ;; 11 | 12 | let show_using_color () = 13 | Stdio.print_endline "Checking whether the inline tests should [use_color]"; 14 | match Ppx_inline_test_lib.use_color () with 15 | | use_color -> Printf.sprintf "\n[use_color] is %b" use_color |> Stdio.print_endline 16 | | exception exn -> 17 | Printf.sprintf "\n%s" (Exn.to_string exn) |> Stdio.print_endline 18 | ;; 19 | 20 | let rec extract_flag args ~flag = 21 | match args with 22 | | [] | [ _ ] -> args, None 23 | | flag' :: arg :: args -> 24 | if String.equal flag' flag 25 | then args, Some arg 26 | else ( 27 | let tl, res = extract_flag (arg :: args) ~flag in 28 | flag' :: tl, res) 29 | ;; 30 | 31 | let () = 32 | let args = Array.to_list (Sys.get_argv ()) in 33 | let args, show_using_color_flag = extract_flag args ~flag:"-show-using-color" in 34 | match show_using_color_flag with 35 | | Some "before" -> show_using_color () 36 | | _ -> 37 | Stdio.print_endline "(About to call [init] the first time)"; 38 | args |> Ppx_inline_test_lib.init |> show_init_result; 39 | (match show_using_color_flag with 40 | | Some "after" -> show_using_color () 41 | | _ -> 42 | Stdio.print_endline "(About to call [init] the second time)"; 43 | args |> Ppx_inline_test_lib.init |> show_init_result; 44 | Stdio.print_endline "(Was able to call [init] twice)") 45 | ;; 46 | -------------------------------------------------------------------------------- /test/only-initialize-once/sub/test.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let%test_unit "running [init] from inside an inline test" = 4 | match 5 | Ppx_inline_test_lib.init 6 | [ "dummy"; "inline-test-runner"; "dummy"; "-list-partitions" ] 7 | with 8 | | Ok _ -> Stdio.print_endline "init succeeded" 9 | | Error err -> Stdio.print_endline err 10 | ;; 11 | -------------------------------------------------------------------------------- /test/only-initialize-once/test-access-settings-after-init.t: -------------------------------------------------------------------------------- 1 | This file tests the accessor functions exposed by [Ppx_inline_test_lib]. We 2 | check that the functions can't be called if the test settings have not yet been 3 | initialized, either because the program is running from an 4 | [inline_tests_runner] executable, or because [init] has been called. 5 | 6 | $ cd $TEST_DIR/sub 7 | 8 | We'd rather not have the exact contents of the help text in the test output below, so we 9 | filter out lines that start with two spaces. 10 | 11 | $ sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib -show-using-color before 12 | Checking whether the inline tests should [use_color] 13 | 14 | (Failure 15 | "ppx_inline_test error: attempted to access the [use_color] config before [init] was called") 16 | 17 | $ sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib -show-using-color after 18 | (About to call [init] the first time) 19 | 20 | Checking whether the inline tests should [use_color] 21 | 22 | [use_color] is true 23 | -------------------------------------------------------------------------------- /test/only-initialize-once/test-only-initialize-once.t: -------------------------------------------------------------------------------- 1 | This file tests the [init] function exposed by [Ppx_inline_test_lib]. We check 2 | that the function can't be called if the test settings were already 3 | initialized, either because the program is running from an 4 | [inline_tests_runner] executable, or because [init] has already been called. We 5 | also check that help, success, and error cases are reported correctly. 6 | 7 | $ cd $TEST_DIR/sub 8 | 9 | $ ./inline_tests_runner 10 | The inline test runner can only be initialized once, and has already been initialized. 11 | 12 | We'd rather not have the exact contents of the help text in the test output below, so we 13 | filter out lines that start with two spaces. 14 | 15 | $ sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib -help | grep -vE '^ ' 16 | (About to call [init] the first time) 17 | 18 | sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib [args] 19 | 20 | (About to call [init] the second time) 21 | 22 | The inline test runner can only be initialized once, and has already been initialized. 23 | (Was able to call [init] twice) 24 | 25 | $ sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib -list-partitions 26 | (About to call [init] the first time) 27 | 28 | (About to call [init] the second time) 29 | 30 | The inline test runner can only be initialized once, and has already been initialized. 31 | (Was able to call [init] twice) 32 | 33 | $ sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib -lst-prt | grep -vE '^ ' 34 | (About to call [init] the first time) 35 | 36 | sample-client/inline_tests_sample_client.exe: unknown option '-lst-prt'. 37 | sample-client/inline_tests_sample_client.exe inline-test-runner dummy-lib [args] 38 | 39 | (About to call [init] the second time) 40 | 41 | The inline test runner can only be initialized once, and has already been initialized. 42 | (Was able to call [init] twice) 43 | 44 | -------------------------------------------------------------------------------- /test/order.ml: -------------------------------------------------------------------------------- 1 | (* checking that the execution order is right (and that 2 | tests do run) *) 3 | 4 | let count = ref 0 5 | 6 | let check i = 7 | assert ( 8 | match Sys.getenv "DONT_ASSUME_ALL_TESTS_RUN" with 9 | | (_ : string) -> true 10 | | exception Not_found -> !count = i); 11 | incr count 12 | ;; 13 | 14 | module F (X : sig 15 | val start : int 16 | end) = 17 | struct 18 | let () = check X.start 19 | let%test_unit _ = check (X.start + 1) 20 | let () = check (X.start + 2) 21 | end 22 | 23 | let () = check 0 24 | let%test_unit _ = check 1 25 | let () = check 2 26 | 27 | let%test _ = 28 | check 3; 29 | true 30 | ;; 31 | 32 | let () = check 4 33 | 34 | module%test _ = struct 35 | let () = check 5 36 | let%test_unit _ = check 6 37 | let () = check 7 38 | 39 | let%test _ = 40 | check 8; 41 | true 42 | ;; 43 | 44 | module%test _ = struct 45 | let () = check 9 46 | 47 | module _ = F (struct 48 | let start = 10 49 | end) 50 | 51 | let () = check 13 52 | end 53 | 54 | module _ = F (struct 55 | let start = 14 56 | end) 57 | 58 | let () = check 17 59 | end 60 | 61 | let () = check 18 62 | -------------------------------------------------------------------------------- /test/order.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/performance_test.ml: -------------------------------------------------------------------------------- 1 | let%test ("alloc-test-ok" [@tags "x-library-inlining-sensitive"]) = true 2 | 3 | (* Let's just pretend we have a test, say an alloc test, that only works with 4 | inlining, and is currently broken. *) 5 | let%test ("alloc-test-fail" [@tags "x-library-inlining-sensitive"]) = false 6 | 7 | module%test [@name "alloc-test-module2"] _ = struct 8 | let%test _ = true 9 | let%test (_ [@tags "x-library-inlining-sensitive"]) = true 10 | end 11 | 12 | module%test [@name "alloc-test-module"] [@tags "x-library-inlining-sensitive"] _ = struct 13 | let%test "ok" = true 14 | let%test "fail" = false 15 | end 16 | 17 | module%test [@name "early-cutoff-module"] [@tags "x-library-inlining-sensitive"] _ = 18 | struct 19 | (* the toplevel of this module should not even be run when we aren't running 20 | the inlining-sensitive tests. *) 21 | let () = assert false 22 | end 23 | -------------------------------------------------------------------------------- /test/performance_test.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/ppx_inline_test_lib_test.ml: -------------------------------------------------------------------------------- 1 | module Config = Config 2 | module Disabled = Disabled 3 | module Failures = Failures 4 | module File_without_test_module = File_without_test_module 5 | module Order = Order 6 | module Performance_test = Performance_test 7 | module Random_state = Random_state 8 | module Unidiomatic_syntax = Unidiomatic_syntax 9 | -------------------------------------------------------------------------------- /test/random_state.ml: -------------------------------------------------------------------------------- 1 | let test list = 2 | ListLabels.iter list ~f:(fun expect -> 3 | let actual = Random.int 1000 in 4 | if actual <> expect then failwith (Printf.sprintf "%d <> %d" actual expect)) 5 | ;; 6 | 7 | (* Random state is repeatable: *) 8 | let in_fresh_inline_test = [ 35; 358; 338 ] 9 | let%test_unit _ = test in_fresh_inline_test 10 | let%test_unit _ = test in_fresh_inline_test 11 | let%test_unit _ = test in_fresh_inline_test 12 | 13 | (* Random state can be overridden: *) 14 | let after_random_init_0 = [ 518; 504; 87 ] 15 | 16 | let%test_unit _ = 17 | Random.init 0; 18 | test after_random_init_0 19 | ;; 20 | 21 | let%test_unit _ = 22 | Random.init 0; 23 | test after_random_init_0 24 | ;; 25 | 26 | let%test_unit _ = 27 | Random.init 0; 28 | test after_random_init_0 29 | ;; 30 | 31 | (* Tests inside a functor restore the existing random state after they run: *) 32 | module Make () = struct 33 | let%test_unit _ = () 34 | end 35 | 36 | let%test_unit _ = 37 | Random.init 0; 38 | let module _ = Make () in 39 | test after_random_init_0 40 | ;; 41 | 42 | let%test_unit _ = 43 | Random.init 0; 44 | let module _ = Make () in 45 | test after_random_init_0 46 | ;; 47 | 48 | let%test_unit _ = 49 | Random.init 0; 50 | let module _ = Make () in 51 | test after_random_init_0 52 | ;; 53 | -------------------------------------------------------------------------------- /test/random_state.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/run-by-partition/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name test-runner-runtime-deps) 3 | (deps 4 | ./sub/inline_tests_runner 5 | ./sub/inline_tests_runner.exe 6 | (glob_files ./sub/*.ml))) 7 | -------------------------------------------------------------------------------- /test/run-by-partition/setup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | TEST_DIR="$(pwd)" 3 | export TEST_DIR 4 | -------------------------------------------------------------------------------- /test/run-by-partition/sub/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_inline_test_run_by_partition) 3 | (preprocess 4 | (pps ppx_jane))) 5 | -------------------------------------------------------------------------------- /test/run-by-partition/sub/ppx_inline_test_run_by_partition.ml: -------------------------------------------------------------------------------- 1 | module Test = Test 2 | -------------------------------------------------------------------------------- /test/run-by-partition/sub/test.ml: -------------------------------------------------------------------------------- 1 | let () = print_string "PRINTED FROM TEST FILE" 2 | let%test _ = false 3 | -------------------------------------------------------------------------------- /test/run-by-partition/test-run-by-partition.t: -------------------------------------------------------------------------------- 1 | When running inline tests, jenga first gets the output of 2 | [inline_tests_runner -list-partitions], then loops through those lines, testing 3 | the partitions one-by-one. If code linked into [inline_tests_runner] produces 4 | other toplevel output, it can mangle the partition list and cause jenga to try 5 | running nonexistent tests instead (while the real ones are silently ignored). 6 | 7 | $ cd $TEST_DIR/sub 8 | 9 | $ ./inline_tests_runner -list-partitions 10 | PRINTED FROM TEST FILEtest 11 | 12 | $ ./inline_tests_runner -list-partitions | while read partition; do ./inline_tests_runner -partition "$partition"; done 13 | PRINTED FROM TEST FILE (no-eol) 14 | 15 | Since the test succeeded, it means no tests were run. 16 | 17 | Instead, we use the [-list-partitions-into-file] flag, which will separate the 18 | partition list from stray STDIO: 19 | 20 | $ PARTITION_FILE=tmp.partitions 21 | $ touch "${PARTITION_FILE}" 22 | 23 | $ ./inline_tests_runner -list-partitions-into-file $PARTITION_FILE 24 | PRINTED FROM TEST FILE (no-eol) 25 | 26 | $ cat $PARTITION_FILE 27 | test 28 | 29 | $ while read partition; do ./inline_tests_runner -partition "$partition"; done < $PARTITION_FILE 30 | File "test.ml", line 2, characters 0-18: <> is false. 31 | 32 | FAILED 1 / 1 tests 33 | PRINTED FROM TEST FILE (no-eol) 34 | [2] 35 | 36 | This time, the test failed (as it should). 37 | 38 | To help catch situations where jenga and the inline_tests_runner can't 39 | communicate over the filesystem (because, for example, the inline_tests_runner 40 | has been wrapped in bwrap), the inline_tests_runner complains if asked to list 41 | partitions into a file that does not exist. 42 | 43 | $ rm $PARTITION_FILE 44 | $ OCAMLRUNPARAM=b=0 ./inline_tests_runner -list-partitions-into-file $PARTITION_FILE 45 | PRINTED FROM TEST FILEFatal error: exception Sys_error("tmp.partitions: No such file or directory") 46 | [2] 47 | 48 | 49 | In reality, jenga does not interact with the inline test runner using real 50 | files. Instead, it runs a script that manipulates some file descriptors to 51 | collect the partition list like so: 52 | 53 | $ exec {stdout}>&1; ./inline_tests_runner -list-partitions-into-file /dev/fd/${stdout} > /dev/null 54 | test 55 | 56 | $ ( exec {stdout}>&1; ./inline_tests_runner -list-partitions-into-file /dev/fd/${stdout} > /dev/null ) | while read partition; do ./inline_tests_runner -partition "$partition"; done 57 | File "test.ml", line 2, characters 0-18: <> is false. 58 | 59 | FAILED 1 / 1 tests 60 | PRINTED FROM TEST FILE (no-eol) 61 | [2] 62 | -------------------------------------------------------------------------------- /test/test-inlining.expected: -------------------------------------------------------------------------------- 1 | Partitions diff: 2 | 2a3 3 | > file_without_test_module 4 | 4a6,7 5 | > random_state 6 | > unidiomatic_syntax 7 | 8 | File "performance_test.ml", line 1, characters 0-72: alloc-test-ok (XXX sec) 9 | File "performance_test.ml", line 5, characters 0-75: alloc-test-fail (XXX sec) 10 | File "performance_test.ml", line 9, characters 2-60: <> (XXX sec) 11 | File "performance_test.ml", line 13, characters 2-22: ok (XXX sec) 12 | File "performance_test.ml", line 14, characters 2-25: fail (XXX sec) 13 | 14 | ====================================================================== 15 | TEST_MODULE at file "failures.ml", line 12, characters 2-70: name3 threw Exit. 16 | in TEST_MODULE at file "failures.ml", line 7, characters 0-170: Name2 17 | 18 | TEST_MODULE at file "failures.ml", line 17, characters 0-48 threw Exit. 19 | 20 | File "performance_test.ml", line 5, characters 0-75: alloc-test-fail is false. 21 | 22 | File "performance_test.ml", line 14, characters 2-25: fail is false. 23 | in TEST_MODULE at file "performance_test.ml", line 12, characters 0-142: alloc-test-module 24 | 25 | TEST_MODULE at file "performance_test.ml", line 17, characters 0-238: early-cutoff-module threw "Assert_failure performance_test.ml:21:11". 26 | 27 | FAILED 2 / 5 tests, 3 TEST_MODULES 28 | code: 2 29 | -------------------------------------------------------------------------------- /test/test.expected: -------------------------------------------------------------------------------- 1 | File "failures.ml", line 4, characters 0-18: <> is false. 2 | 3 | File "failures.ml", line 5, characters 0-29: name1 threw Exit. 4 | 5 | File "failures.ml", line 8, characters 2-20: <> is false. 6 | in TEST_MODULE at file "failures.ml", line 7, characters 0-170: Name2 7 | 8 | File "failures.ml", line 9, characters 2-20: <> is false. 9 | in TEST_MODULE at file "failures.ml", line 7, characters 0-170: Name2 10 | 11 | File "failures.ml", line 10, characters 2-25: <> threw Exit. 12 | in TEST_MODULE at file "failures.ml", line 7, characters 0-170: Name2 13 | 14 | TEST_MODULE at file "failures.ml", line 12, characters 2-70: name3 threw Exit. 15 | in TEST_MODULE at file "failures.ml", line 7, characters 0-170: Name2 16 | 17 | TEST_MODULE at file "failures.ml", line 17, characters 0-48 threw Exit. 18 | 19 | File "failures.ml", line 22, characters 0-30: name4 is false. 20 | 21 | FAILED 6 / 28 tests, 2 TEST_MODULES 22 | code: 2 23 | -------------------------------------------------------------------------------- /test/unidiomatic_syntax.ml: -------------------------------------------------------------------------------- 1 | [%%test_unit let _ = ()] 2 | -------------------------------------------------------------------------------- /test/unidiomatic_syntax.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | --------------------------------------------------------------------------------