pax_global_header00006660000000000000000000000064145065207760014526gustar00rootroot0000000000000052 comment=b91f87ccba21c9f6be12f729872fa347bf5bc6e6 ppx_inline_test-0.16.1/000077500000000000000000000000001450652077600150175ustar00rootroot00000000000000ppx_inline_test-0.16.1/.gitignore000066400000000000000000000000411450652077600170020ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_inline_test-0.16.1/CHANGES.md000066400000000000000000000043771450652077600164240ustar00rootroot00000000000000## Release v0.16.0 - Renamed `Ppx_inline_test_runner.Runtime` to `Ppx_inline_test_runner` - Renamed `Ppx_inline_test_runner.Runtime.am_running_inline_test{,_env_var}` to `Ppx_inline_test_runner.am_running{,_env_var}` - New tag `let%test _ [@tags "disabled"]` for tests that shouldn't run by default - Make the README state how to pass flags to the inline tests runner in jbuild/dune files - A bit of progress towards supporting running tests in parallel with dune (from @hhugo) ## Old pre-v0.15 changelogs (very likely stale and incomplete) ## v0.13.1 - Honor the `inline_tests` Dune variable so that inline tests are dropped in release builds ## v0.11 - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and ppx\_metaquot. ## 113.33.03 - Changed the runtime API to make it easier to build test runners: replace the `Runtime.Test_result.record` system by `Runtime.add_evaluator` - Tell the build system via output metadata whether a file contains tests or not ## 113.33.00 - Allow to configure hooks for inline tests by redefining a module Inline\_test\_config. ## 113.24.00 - Support literate-style .ml files that allow ocaml code interleaved with expected output annotations. Compiling with the `ppx_expect_test` generates a program that outputs the original source file, but with the actual output substituted for the expected-output annotations. Then we can pat-diff the original file against the output file. Testing ------- Examples in the test/ and example/ folders. - Expect-tests can now be written inline in libraries by using `let%expect_test`. The runtime library has been split into two components: the test runner, which collects the output of the test body, and registers enough information to construct the `*.ml.corrected` file from the input; and the test evaluator, which compares the test output against the expected output and generates the output files. - Update to follow `Ppx_core` evolution. - When an exception is raised inside a `let%test_module`, display the position and name of the TEST\_MODULE, same as for the `let%test`. - Mark attributes as handled inside explicitly dropped pieces of code. So that a `@@deriving` inside a let%test dropped by `ppx_inline_test_drop` doesn't cause a failure. ppx_inline_test-0.16.1/CONTRIBUTING.md000066400000000000000000000044101450652077600172470ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_inline_test-0.16.1/LICENSE.md000066400000000000000000000021461450652077600164260ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_inline_test-0.16.1/Makefile000066400000000000000000000004031450652077600164540ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_inline_test-0.16.1/README.md000066400000000000000000000201461450652077600163010ustar00rootroot00000000000000ppx_inline_test =============== Syntax extension for writing in-line tests in ocaml code. New syntactic constructs ------------------------ The following constructs are now valid structure items: ```ocaml let%test "name" = (* true means ok, false or exn means broken *) let%test_unit "name" = (* () means ok, exn means broken *) let%test_module "name" = (module ) (* to group tests (to share some setup for instance) *) ``` We may write `_` instead of `"name"` for anonymous tests. It is also possible to use `[%name ]` for a dynamically computed name. When running tests, they will be executed when the control flow reaches the structure item (i.e. at toplevel for a toplevel test; when the functor is applied for a test defined in the body of a functor, etc.). Tags ---- One can tag tests with the following construct: ```ocaml let%test "name" [@tags "no-js"] = let%test "name" [@tags "no-js", "other-tag"] = let%test _ [@tags "no-js"] = let%test _ [@tags "js-only"] = ``` Available tags are: * `no-js` for tests that should not run when compiling Ocaml to Javascript * `js-only` for tests that should only run in Javascript * `32-bits-only` for tests that should only run in 32 bits architectures * `64-bits-only` for tests that should only run in 64 bits architectures * `fast-flambda` for tests that might only pass when compiling with flambda, -O3 and cross library inlining * `x-library-inlining-sensitive` for tests that might only pass when compiling with cross library inlining switched on * `disabled` for tests that should not run (unless requested with -require-tag) One can also tag entire test modules similarly: ```ocaml let%test_module "name" [@tags "no-js"] = (module struct end) ``` The flags `-drop-tag` and `-require-tag` can be passed to the test runner to restrict which tests are run. We say the tags of a test are the union of the tags applied directly to that test using `[@tags ...]` and the tags of all enclosing modules. It is to this union that the predicates `-drop-tag` and `-require-tag` are applied. If it is clear, from a test-module's tags, that none of the tests within will possibly match the tag predicates imposed by the command line flags, then additionally the top-level of that module will not be run. Examples -------- ### prime.ml ```ocaml let is_prime = let%test _ = is_prime 5 let%test _ = is_prime 7 let%test _ = not (is_prime 1) let%test _ = not (is_prime 8) ``` ### Tests in a functor. ```ocaml module Make(C : S) = struct let%test _ = end module M = Make(Int) ``` ### Grouping test and side-effecting initialisation. Since the module passed as an argument to `let%test_module` is only initialised when we run the tests, it is ok to perform side-effects in the module-expression argument. ```ocaml let%test_module _ = (module struct module UID = Unique_id.Int(struct end) let%test _ = UID.create() <> UID.create() end) ``` Building and running the tests at jane street -------------------------------- Inline tests can only be used in libraries, not executables. The standard build rules create an executable script `inline_tests_runner` which runs all tests in the directory. This script takes optional arguments (see below) to restrict which tests are run. The full set of tests are run when building the jenga `runtest` alias. jenga .runtest Building and running the tests outside of jane street with dune ---------------------------------------- Inline tests can only be used in libraries, not executables. To use this with dune, see [dune's documentation](https://dune.readthedocs.io/en/latest/tests.html). At the time of writing of the current document, the short version is: * define a library this way: ```lisp (library (name foo) (inline_tests) (preprocess (pps ppx_inline_test))) ``` * add tests to it * call `dune runtest` Building and running the tests outside of jane street without dune ---------------------------------------- Code using this extension must be compiled and linked using the `ppx_inline_test.runtime-lib` library. The `ppx_inline_test` syntax extension will reject any test if it wasn't passed a `-inline-test-lib libname` flag. #### Execution Tests are only executed when both these conditions are met: - the executable containing the tests is linked with `ppx_inline_test.runner.lib` - the executable containing the tests is called with command line arguments: your.exe inline-test-runner libname [options] This `libname` is a way of restricting the tests run by the executable. The dependencies of your library (or executable) could also use `ppx_inline_test`, but you don't necessarily want to run their tests too. For instance, `core` is built by giving `-inline-test-lib core` and `core_extended` is built by giving `-inline-test-lib core_extended`. And now when an executable linked with both `core` and `core_extended` is run with a `libname` of `core_extended`, only the tests of `core_extended` are run. Finally, after running tests, `Ppx_inline_test_lib.exit ()` should be called (to exit with an error and a summary of the number of failed tests if there were errors or exit normally otherwise). One can construct a dual-use binary that only runs the tests when prompted to (through the command line), by sticking the following piece of code in it, after the tests have run but before the binary starts doing non-test side effects. However be aware that `Base.am_testing` will be `true` even when not running tests, which may be undesirable. ```ocaml match Ppx_inline_test_lib.testing with | `Testing `Am_test_runner -> print_endline "Exiting test suite"; Ppx_inline_test_lib.exit () | `Testing _ -> exit 0 | `Not_testing -> () ``` Command line arguments ---------------------- The executable that runs tests can take additional command line arguments. The most useful of these are: * `-stop-on-error` Stop running tests after the first error. * `-verbose` to see the tests as they run * `-only-test location` where location is either a filename `-only-test main.ml`, a filename with a line number `-only-test main.ml:32`, or with the syntax that the compiler uses: `File "main.ml"`, or `File "main.ml", line 32` or `File "main.ml", line 32, characters 2-6` (characters are ignored). The position that matters is the position of the `let%test` or `let%test_unit`. The positions shown by `-verbose` are valid inputs for `-only-test`. If no `-only-test` flag is given, all the tests are run. Otherwise all the tests matching any of the locations are run. * `-drop-tag tag` drop all the tests tagged with `tag`. These can be specified to jenga like this: ``` (library (... (inline_tests ((flags (-stop-on-error)))) ... )) ``` and to dune like this: ``` (library ... (inline_tests (flags (-stop-on-error))) ...) ``` Parallelizing tests ------------------- If you pass arguments of the form `-inline-test-lib lib:partition` to `ppx_inline_test`, then you will be able to run tests from a given source file in parallel with tests from other source files. All the tests inside the same source file are still run sequentially. You should pick different `partition` names for the different files in your library (the name of the .ml files for instance). `ppx_inline_test_lib` currently requires some external system like a build system to run it multiple times in parallel, although we may make it possible to run the inline tests in parallel directly in the future. If you do that, you can now use two new flags of the executable containing the tests: * `-list-partitions` lists all the partitions that contain at least one test, one per line. * `-partition P` only run the tests of the library that are encountered at toplevel of the source file that was preprocessed with the given partition `P` (the tests need not be syntactically in the file, they could be the result of applying a functor) A build system can combine these two commands by first listing partitions, and then running one command for each partition. ppx_inline_test-0.16.1/config/000077500000000000000000000000001450652077600162645ustar00rootroot00000000000000ppx_inline_test-0.16.1/config/dune000066400000000000000000000001631450652077600171420ustar00rootroot00000000000000(library (name inline_test_config) (public_name ppx_inline_test.config) (libraries) (preprocess no_preprocessing))ppx_inline_test-0.16.1/config/inline_test_config.ml000066400000000000000000000001271450652077600224600ustar00rootroot00000000000000module type S = sig val pre_test_hook : unit -> unit end let pre_test_hook = ignore ppx_inline_test-0.16.1/config/inline_test_config.mli000066400000000000000000000006401450652077600226310ustar00rootroot00000000000000(** Configuration for running inline tests *) (** To configure inline_test, add the following at the top of your .ml file, or in some import.ml: {[ module Inline_test_config = struct include Inline_test_config let pre_test_hook () = ... end ]} *) module type S = sig (** Run this function at the beginning of any test *) val pre_test_hook : unit -> unit end include S ppx_inline_test-0.16.1/drop/000077500000000000000000000000001450652077600157635ustar00rootroot00000000000000ppx_inline_test-0.16.1/drop/dune000066400000000000000000000002301450652077600166340ustar00rootroot00000000000000(library (name ppx_inline_test_drop) (public_name ppx_inline_test.drop) (kind ppx_rewriter) (libraries ppx_inline_test) (preprocess no_preprocessing))ppx_inline_test-0.16.1/drop/ppx_inline_test_drop.ml000066400000000000000000000000651450652077600225460ustar00rootroot00000000000000let () = Ppx_inline_test.set_default_maybe_drop Drop ppx_inline_test-0.16.1/dune000066400000000000000000000000001450652077600156630ustar00rootroot00000000000000ppx_inline_test-0.16.1/dune-project000066400000000000000000000000171450652077600173370ustar00rootroot00000000000000(lang dune 3.8)ppx_inline_test-0.16.1/example/000077500000000000000000000000001450652077600164525ustar00rootroot00000000000000ppx_inline_test-0.16.1/example/dune000066400000000000000000000001441450652077600173270ustar00rootroot00000000000000(library (name ppx_inline_test_example_lib) (libraries core core_unix) (preprocess (pps ppx_jane)))ppx_inline_test-0.16.1/example/example.ml000066400000000000000000000025211450652077600204370ustar00rootroot00000000000000open Core open Poly module Unix = Core_unix module type S = sig type t val zero : t val succ : t -> t end module type Cnt = sig type t val _incr : unit -> t end module Cnt (V : S) : Cnt with type t = V.t = struct type t = V.t let p = ref V.zero let _incr () = p := V.succ !p; !p ;; let%test _ = V.succ V.zero > V.zero end module _ = Cnt (Int) let%test_module _ = (module Cnt (Int)) let%test_module "description" = (module Cnt (Int)) let%test_module _ = (module struct open List let%test _ = group [] ~break:(fun _ -> assert false) = [] let mis = [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] let equal_letters = [ [ 'M' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 's'; 's' ] ; [ 'i' ] ; [ 'p'; 'p' ] ; [ 'i' ] ] ;; let single_letters = [ [ 'M'; 'i'; 's'; 's'; 'i'; 's'; 's'; 'i'; 'p'; 'p'; 'i' ] ] let every_three = [ [ 'M'; 'i'; 's' ]; [ 's'; 'i'; 's' ]; [ 's'; 'i'; 'p' ]; [ 'p'; 'i' ] ] ;; let%test _ = group ~break:( <> ) mis = equal_letters let%test _ = group ~break:(fun _ _ -> false) mis = single_letters let%test _ = groupi ~break:(fun i _ _ -> i mod 3 = 0) mis = every_three let%test "slow, but takes no cpu time" = ignore (Unix.nanosleep 0.25 : float); true ;; end) ;; ppx_inline_test-0.16.1/example/example.mli000066400000000000000000000000131450652077600206020ustar00rootroot00000000000000open! Core ppx_inline_test-0.16.1/libname/000077500000000000000000000000001450652077600164265ustar00rootroot00000000000000ppx_inline_test-0.16.1/libname/dune000066400000000000000000000002001450652077600172740ustar00rootroot00000000000000(library (name ppx_inline_test_libname) (public_name ppx_inline_test.libname) (libraries ppxlib) (preprocess no_preprocessing))ppx_inline_test-0.16.1/libname/ppx_inline_test_libname.ml000066400000000000000000000015151450652077600236550ustar00rootroot00000000000000open Ppxlib let libname_and_partition = ref None let () = Driver.add_arg "-inline-test-lib" (Arg.String (fun lib -> let p = match String.index lib ':' with | exception Not_found -> lib, None | i -> String.sub lib 0 i, Some (String.sub lib (i + 1) (String.length lib - i - 1)) in libname_and_partition := Some p)) ~doc: " A base name to use for generated identifiers (has to be globally unique in a \ program). ppx_inline_test (and ppx_bench) are disabled unless this flag is \ passed." ;; let () = Driver.Cookies.add_simple_handler "library-name" Ast_pattern.(estring __) ~f:(function | None -> () | Some lib -> libname_and_partition := Some (lib, None)) ;; let get () = !libname_and_partition ppx_inline_test-0.16.1/libname/ppx_inline_test_libname.mli000066400000000000000000000003151450652077600240230ustar00rootroot00000000000000(** This library defines the command line argument -inline-test-lib (and ppxlib cookie library-name), shared by both ppx_bench and ppx_inline_test. *) val get : unit -> (string * string option) option ppx_inline_test-0.16.1/ppx_inline_test.opam000066400000000000000000000014471450652077600211070ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.1" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_inline_test" bug-reports: "https://github.com/janestreet/ppx_inline_test/issues" dev-repo: "git+https://github.com/janestreet/ppx_inline_test.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_inline_test/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "base" {>= "v0.16" & < "v0.17"} "time_now" {>= "v0.16" & < "v0.17"} "dune" {>= "3.8.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Syntax extension for writing in-line tests in ocaml code" description: " Part of the Jane Street's PPX rewriters collection. " ppx_inline_test-0.16.1/runner/000077500000000000000000000000001450652077600163305ustar00rootroot00000000000000ppx_inline_test-0.16.1/runner/dune000066400000000000000000000003001450652077600171770ustar00rootroot00000000000000(library (name ppx_inline_test_runner) (public_name ppx_inline_test.runner) (libraries ppx_inline_test_lib ppx_inline_test_runner_lib) (library_flags -linkall) (preprocess no_preprocessing))ppx_inline_test-0.16.1/runner/lib/000077500000000000000000000000001450652077600170765ustar00rootroot00000000000000ppx_inline_test-0.16.1/runner/lib/am_testing.c000066400000000000000000000001221450652077600213670ustar00rootroot00000000000000#include CAMLprim value Base_am_testing() { return Val_true; } ppx_inline_test-0.16.1/runner/lib/dune000066400000000000000000000003771450652077600177630ustar00rootroot00000000000000(library (name ppx_inline_test_runner_lib) (public_name ppx_inline_test.runner.lib) (js_of_ocaml (flags --no-sourcemap) (javascript_files runtime.js)) (foreign_stubs (language c) (names am_testing)) (libraries base) (preprocess no_preprocessing))ppx_inline_test-0.16.1/runner/lib/runtime.js000066400000000000000000000001151450652077600211140ustar00rootroot00000000000000//Provides: Base_am_testing const function Base_am_testing(x) { return 1 } ppx_inline_test-0.16.1/runner/ppx_inline_test_runner.ml000066400000000000000000000000451450652077600234560ustar00rootroot00000000000000let () = Ppx_inline_test_lib.exit () ppx_inline_test-0.16.1/runner/ppx_inline_test_runner.mli000066400000000000000000000000551450652077600236300ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/runtime-lib/000077500000000000000000000000001450652077600172465ustar00rootroot00000000000000ppx_inline_test-0.16.1/runtime-lib/dune000066400000000000000000000002321450652077600201210ustar00rootroot00000000000000(library (name ppx_inline_test_lib) (public_name ppx_inline_test.runtime-lib) (libraries base inline_test_config time_now) (preprocess no_preprocessing))ppx_inline_test-0.16.1/runtime-lib/ppx_inline_test_lib.ml000066400000000000000000000607271450652077600236460ustar00rootroot00000000000000module Test_result = struct type t = | Success | Failure | Error let to_exit_code = function | Success -> 0 | Failure -> 2 | Error -> 1 ;; let to_string = function | Success -> "success" | Failure -> "failure" | Error -> "error" ;; let combine t1 t2 = match t1, t2 with | Success, Success -> Success | Error, _ | _, Error -> Error | Failure, _ | _, Failure -> Failure ;; let combine_all ts = List.fold_left combine Success ts end let parse_argv argv l f msg = try Arg.parse_argv argv l f msg with | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 1 | Arg.Help msg -> Printf.printf "%s" msg; exit 0 ;; type descr = string let test_modules_ran = ref 0 let test_modules_failed = ref 0 let tests_ran = ref 0 let tests_failed = ref 0 let dynamic_lib : string option ref = ref None type filename = string type line_number = int type start_pos = int type end_pos = int type config = (module Inline_test_config.S) type 'a test_function_args = config:config -> descr:descr Lazy.t -> tags:string list -> filename:filename -> line_number:line_number -> start_pos:start_pos -> end_pos:end_pos -> 'a module Tag_predicate = struct type t = { required_tags : string list ; dropped_tags : string list } let initial = { required_tags = []; dropped_tags = [ "disabled" ] } let drop t tag = { dropped_tags = tag :: t.dropped_tags ; required_tags = List.filter (( <> ) tag) t.required_tags } ;; let require t tag = { dropped_tags = List.filter (( <> ) tag) t.dropped_tags ; required_tags = tag :: t.required_tags } ;; let entire_module_disabled t ~partial_tags:tags = List.exists (fun dropped -> List.mem dropped tags) t.dropped_tags ;; let disabled t ~complete_tags:tags = List.exists (fun req -> not (List.mem req tags)) t.required_tags || List.exists (fun dropped -> List.mem dropped tags) t.dropped_tags ;; end type which_tests = { libname : string ; only_test_location : (filename * line_number option * bool ref) list ; name_filter : string list ; which_tags : Tag_predicate.t } type test_mode = { which_tests : which_tests ; what_to_do : [ `Run_partition of string option | `List_partitions ] } module Action : sig type t = [ `Ignore | `Test_mode of test_mode ] val get : unit -> t val set : t -> unit end = struct type t = [ `Ignore | `Test_mode of test_mode ] let action : t ref = ref `Ignore let force_drop = try ignore (Sys.getenv "FORCE_DROP_INLINE_TEST" : string); true with | Not_found -> false ;; let get () = (* This is useful when compiling to javascript. Js_of_ocaml can statically evaluate [Sys.getenv "FORCE_DROP_INLINE_TEST"] and inline the result ([`Ignore]) whenever [get ()] is called. Unit tests can then be treated as deadcode since the argument [f] of the [test] function below is never used. *) if force_drop then `Ignore else !action ;; let set v = action := v end module Partition : sig val found_test : unit -> unit val set_current : string -> unit val is_current : string option -> bool val all : unit -> string list end = struct let all = Hashtbl.create 23 let current = ref "" let set_current x = current := x let found_test () = if !current <> "" && not (Hashtbl.mem all !current) then Hashtbl.add all !current () ;; let is_current = function | None -> true | Some p -> p = !current ;; let all () = List.sort String.compare (Hashtbl.fold (fun k () acc -> k :: acc) all []) end module Module_context = struct module T = struct type one_module = { descr : string ; tags : string list } type t = one_module list let descr t = List.map (fun m -> m.descr) t let tags t = List.concat (List.map (fun m -> m.tags) t) end let current : T.t ref = ref [] let with_ ~descr ~tags f = let prev = !current in current := { T.descr; tags } :: prev; try let x = f () in current := prev; x with | e -> current := prev; raise e ;; let current_descr () = T.descr !current let current_tags () = T.tags !current end let verbose = ref false let strict = ref false let show_counts = ref false let list_test_names = ref false let delayed_errors = ref [] let stop_on_error = ref false let log = ref None let time_sec = ref 0. let use_color = ref true let in_place = ref false let diff_command = ref None let source_tree_root = ref None let diff_path_prefix = ref None let displayed_descr descr filename line start_pos end_pos = let (lazy descr) = descr in Printf.sprintf "File %S, line %d, characters %d-%d%s" filename line start_pos end_pos (if descr = "" then "" else ": " ^ descr) ;; let parse_descr str = try Some (Scanf.sscanf str " File %S , line %d , characters %d - %d %!" (fun file line _start_pos _end_pos -> file, Some line)) with | _ -> (try Some (Scanf.sscanf str " File %S , line %d %!" (fun file line -> file, Some line)) with | _ -> (try Some (Scanf.sscanf str " File %S %!" (fun file -> file, None)) with | _ -> None)) ;; let () = if Base.Exported_for_specific_uses.am_testing then ( match Array.to_list Sys.argv with | name :: "inline-test-runner" :: lib :: rest -> (* when we see this argument, we switch to test mode *) let tests = ref [] in let list_partitions = ref false in let partition = ref None in let tag_predicate = ref Tag_predicate.initial in let name_filter = ref [] in parse_argv (Array.of_list (name :: rest)) (Arg.align [ ( "-list-test-names" , Arg.Unit (fun () -> list_test_names := true; verbose := true) , " Do not run tests but show what would have been run" ) ; ( "-list-partitions" , Arg.Unit (fun () -> list_partitions := true) , " Lists all the partitions that contain at least one test or test_module" ) ; ( "-partition" , Arg.String (fun i -> partition := Some i) , " Only run the tests in the given partition" ) ; "-verbose", Arg.Set verbose, " Show the tests as they run" ; ( "-stop-on-error" , Arg.Set stop_on_error , " Run tests only up to the first error (doesn't work for expect tests)" ) ; "-strict", Arg.Set strict, " End with an error if no tests were run" ; "-show-counts", Arg.Set show_counts, " Show the number of tests ran" ; ( "-log" , Arg.Unit (fun () -> (try Sys.remove "inline_tests.log" with | _ -> ()); log := Some (open_out "inline_tests.log")) , " Log the tests run in inline_tests.log" ) ; ( "-drop-tag" , Arg.String (fun s -> tag_predicate := Tag_predicate.drop !tag_predicate s) , "tag Only run tests not tagged with [tag] (overrides previous \ -require-tag)" ) ; ( "-require-tag" , Arg.String (fun s -> tag_predicate := Tag_predicate.require !tag_predicate s) , "tag Only run tests tagged with [tag] (overrides previous -drop-tag)" ) ; ( "-matching" , Arg.String (fun s -> name_filter := s :: !name_filter) , "substring Only run tests whose names contain the given substring" ) ; ( "-only-test" , Arg.String (fun s -> let filename, index = match parse_descr s with | Some (file, index) -> file, index | None -> if String.contains s ':' then ( let i = String.index s ':' in let filename = String.sub s 0 i in let index_string = String.sub s (i + 1) (String.length s - i - 1) in let index = try int_of_string index_string with | Failure _ -> Printf.eprintf "Argument %s doesn't fit the format filename[:line_number]\n\ %!" s; exit 1 in filename, Some index) else s, None in tests := (filename, index, ref false) :: !tests) , "location Run only the tests specified by all the -only-test options.\n\ \ Locations can be one of these forms:\n\ \ - file.ml\n\ \ - file.ml:line_number\n\ \ - File \"file.ml\"\n\ \ - File \"file.ml\", line 23\n\ \ - File \"file.ml\", line 23, characters 2-3" ) ; "-no-color", Arg.Clear use_color, " Summarize tests without using color" ; "-in-place", Arg.Set in_place, " Update expect tests in place" ; ( "-diff-cmd" , Arg.String (fun s -> diff_command := Some s) , " Diff command for tests that require diffing (use - to disable diffing)" ) ; ( "-source-tree-root" , Arg.String (fun s -> source_tree_root := Some s) , " Path to the root of the source tree" ) ; ( "-diff-path-prefix" , Arg.String (fun s -> diff_path_prefix := Some s) , " Prefix to prepend to filepaths in test output" ) ]) (fun anon -> Printf.eprintf "%s: unexpected anonymous argument %s\n%!" name anon; exit 1) (Printf.sprintf "%s %s %s [args]" name "inline-test-runner" lib); Action.set (`Test_mode { which_tests = { libname = lib ; only_test_location = !tests ; which_tags = !tag_predicate ; name_filter = !name_filter } ; what_to_do = (if !list_partitions then `List_partitions else `Run_partition !partition) }) | _ -> ()) ;; let am_test_runner = match Action.get () with | `Test_mode _ -> true | `Ignore -> false ;; let am_running_env_var = (* for approximate compatibility, given that the variable is not exactly equivalent to what PPX_INLINE_TEST_LIB_AM_RUNNING_INLINE_TEST used to be *) "TESTING_FRAMEWORK" ;; (* This value is deprecated in principle, in favor of Core.am_running_test, so we're going to live with the ugly pattern match. *) let am_running = match Sys.getenv "PPX_INLINE_TEST_LIB_AM_RUNNING_INLINE_TEST" with | (_ : string) -> true (* for compatibility with people setting this variable directly *) | exception Not_found -> (match Sys.getenv am_running_env_var with | "inline-test" -> true | exception Not_found -> false | _ -> false) ;; let testing = if am_test_runner then `Testing `Am_test_runner else if am_running then `Testing `Am_child_of_test_runner else `Not_testing ;; let wall_time_clock_ns () = Time_now.nanoseconds_since_unix_epoch () let where_to_cut_backtrace = lazy (Base.String.Search_pattern.create (__MODULE__ ^ "." ^ "time_without_resetting_random_seeds")) ;; let time_without_resetting_random_seeds f = let before_ns = wall_time_clock_ns () in let res = (* To avoid noise in backtraces, we do two things. We use [where_to_cut_backtrace] above to remove the stack frames for the current function and any function it gets inlined into, as it's not of any interest to the user, since it's not talking about their test but instead talking about the ppx_inline_test machinery. We also avoid inserting any code between the [f] that comes from the user's file and grabbing the backtrace from its exceptions (no wrapping of [f] with high order functions like Exn.protect, or (fun () -> f (); true)). *) try Ok (f ()) with | exn -> Error (exn, Printexc.get_backtrace ()) in time_sec := Base.Int63.(wall_time_clock_ns () - before_ns |> to_float) /. 1e9; res ;; let saved_caml_random_state = lazy (Stdlib.Random.State.make [| 100; 200; 300 |]) let saved_base_random_state = lazy (Base.Random.State.make [| 111; 222; 333 |]) let time_and_reset_random_seeds f = let caml_random_state = Stdlib.Random.get_state () in let base_random_state = Base.Random.State.copy Base.Random.State.default in Stdlib.Random.set_state (Lazy.force saved_caml_random_state); Base.Random.set_state (Lazy.force saved_base_random_state); let result = time_without_resetting_random_seeds f in Stdlib.Random.set_state caml_random_state; Base.Random.set_state base_random_state; result ;; let string_of_module_descr () = String.concat "" (List.map (fun s -> " in TES" ^ "T_MODULE at " ^ String.uncapitalize_ascii s ^ "\n") (Module_context.current_descr ())) ;; let position_match def_filename def_line_number l = List.exists (fun (filename, line_number_opt, used) -> let position_start = String.length def_filename - String.length filename in let found = position_start >= 0 && let end_of_def_filename = String.sub def_filename position_start (String.length filename) in end_of_def_filename = filename && (position_start = 0 || def_filename.[position_start - 1] = '/') && match line_number_opt with | None -> true | Some line_number -> def_line_number = line_number in if found then used := true; found) l ;; let name_filter_match ~name_filter descr = match name_filter with | [] -> true | _ :: _ -> List.exists (fun substring -> Base.String.is_substring ~substring descr) name_filter ;; let print_delayed_errors () = match List.rev !delayed_errors with | [] -> () | _ :: _ as delayed_errors -> Printf.eprintf "\n%s\n%!" (String.make 70 '='); List.iter (fun message -> Printf.eprintf "%s%!" message) delayed_errors ;; let eprintf_or_delay fmt = Printf.ksprintf (fun s -> if !verbose then delayed_errors := s :: !delayed_errors else Printf.eprintf "%s%!" s; if !stop_on_error then ( print_delayed_errors (); exit 2)) fmt ;; let add_hooks ((module C) : config) f () = C.pre_test_hook (); f () ;; let hum_backtrace backtrace = let open Base in backtrace |> String.split_lines |> List.take_while ~f:(fun str -> not (String.Search_pattern.matches (force where_to_cut_backtrace) str)) |> List.map ~f:(fun str -> " " ^ str ^ "\n") |> String.concat ;; let[@inline never] test_inner ~config ~descr ~tags ~filename:def_filename ~line_number:def_line_number ~start_pos ~end_pos f bool_of_f = match Action.get () with | `Ignore -> () | `Test_mode { which_tests = { libname; only_test_location; which_tags; name_filter } ; what_to_do } -> let f = add_hooks config f in let descr = lazy (displayed_descr descr def_filename def_line_number start_pos end_pos) in let complete_tags = tags @ Module_context.current_tags () in let should_run = Some libname = !dynamic_lib && (match only_test_location with | [] -> true | _ :: _ -> position_match def_filename def_line_number only_test_location) && (not (Tag_predicate.disabled which_tags ~complete_tags)) && name_filter_match ~name_filter (Lazy.force descr) in if should_run then ( match what_to_do with | `List_partitions -> Partition.found_test () | `Run_partition partition -> if Partition.is_current partition then ( let descr = Lazy.force descr in incr tests_ran; (match !log with | None -> () | Some ch -> Printf.fprintf ch "%s\n%s" descr (string_of_module_descr ())); if !verbose then Printf.printf "%s%!" descr; let result = if !list_test_names then Ok true else (* See [time_without_resetting_random_seeds] for why we use [bool_of_f] rather have the caller wrap [f] to adjust its return value. *) Result.map bool_of_f (time_and_reset_random_seeds f) in (* If !list_test_names, this is is a harmless zero. *) if !verbose then Printf.printf " (%.3f sec)\n%!" !time_sec; match result with | Ok true -> () | Ok false -> incr tests_failed; eprintf_or_delay "%s is false.\n%s\n%!" descr (string_of_module_descr ()) | Error (exn, backtrace) -> incr tests_failed; let backtrace = hum_backtrace backtrace in let exn_str = Sexplib0.Sexp_conv.printexc_prefer_sexp exn in let sep = if String.contains exn_str '\n' then "\n" else " " in eprintf_or_delay "%s threw%s%s.\n%s%s\n%!" descr sep exn_str backtrace (string_of_module_descr ()))) ;; let set_lib_and_partition static_lib partition = match !dynamic_lib with | Some _ -> (* possible if the interface is used explicitly or if we happen to dynlink something that contain tests *) () | None -> dynamic_lib := Some static_lib; (match Action.get () with | `Ignore -> () | `Test_mode { which_tests; what_to_do } -> if which_tests.libname = static_lib then ( let requires_partition = match what_to_do with | `List_partitions | `Run_partition (Some _) -> true | `Run_partition None -> false in if partition = "" && requires_partition then failwith "ppx_inline_test: cannot use -list-partition or -partition without \ specifying a partition at preprocessing time" else Partition.set_current partition)) ;; let unset_lib static_lib = match !dynamic_lib with | None -> (* not giving an error, because when some annoying people put pa_ounit in their list of preprocessors, pa_ounit is set up twice and we have two calls to unset_lib at the end of the file, and the second one comes in this branch *) () | Some lib -> if lib = static_lib then dynamic_lib := None ;; let test ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f = test_inner ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f (fun b -> b) ;; let test_unit ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f = test_inner ~config ~descr ~tags ~filename ~line_number ~start_pos ~end_pos f (fun () -> true) ;; let[@inline never] test_module ~config ~descr ~tags ~filename:def_filename ~line_number:def_line_number ~start_pos ~end_pos f = match Action.get () with | `Ignore -> () | `Test_mode { which_tests = { libname; only_test_location = _; name_filter = _; which_tags } ; what_to_do } -> let f = add_hooks config f in let descr () = displayed_descr descr def_filename def_line_number start_pos end_pos in let partial_tags = tags @ Module_context.current_tags () in let should_run = Some libname = !dynamic_lib (* If, no matter what tags a test defines, we certainly will drop all tests within this module, then don't run the module at all. This means people can write things like the following without breaking the 32-bit build: let%test_module [@tags "64-bits-only"] = (module struct let i = Int64.to_int_exn .... end) We don't shortcut based on position, as we can't tell what positions the inner tests will have. *) && not (Tag_predicate.entire_module_disabled which_tags ~partial_tags) in if should_run then ( match what_to_do with | `List_partitions -> Partition.found_test () | `Run_partition partition -> if Partition.is_current partition then ( incr test_modules_ran; let descr = descr () in match Module_context.with_ ~descr ~tags (fun () -> (* We do not reset random states upon entering [let%test_module]. Con: Code in test modules can accidentally depend on top-level random state effects. Pros: (1) We don't reset to the same seed on entering a [let%test_module] and then a [let%test] inside that module, which could lead to accidentally randomly generating the same values in some test. (2) Moving code into and out of [let%test_module] does not change its random seed. *) time_without_resetting_random_seeds f) with | Ok () -> () | Error (exn, backtrace) -> incr test_modules_failed; let backtrace = hum_backtrace backtrace in let exn_str = Sexplib0.Sexp_conv.printexc_prefer_sexp exn in let sep = if String.contains exn_str '\n' then "\n" else " " in eprintf_or_delay ("TES" ^^ "T_MODULE at %s threw%s%s.\n%s%s\n%!") (String.uncapitalize_ascii descr) sep exn_str backtrace (string_of_module_descr ()))) ;; let summarize () = match Action.get () with | `Ignore -> if Sys.argv <> [||] && Filename.basename Sys.argv.(0) = "inline_tests_runner.exe" then Printf.eprintf "inline_tests_runner.exe is not supposed to be run by hand, you \n\ should run the inline_tests_runner script instead.\n\ %!" else Printf.eprintf "You are doing something unexpected with the tests. No tests have \n\ been run. You should use the inline_tests_runner script to run \n\ tests.\n\ %!"; Test_result.Error | `Test_mode { which_tests = _; what_to_do = `List_partitions } -> List.iter (Printf.printf "%s\n") (Partition.all ()); Test_result.Success | `Test_mode { what_to_do = `Run_partition _; which_tests } -> (match !log with | None -> () | Some ch -> close_out ch); print_delayed_errors (); (match !tests_failed, !test_modules_failed with | 0, 0 -> if !show_counts then Printf.eprintf "%d tests ran, %d test_modules ran\n%!" !tests_ran !test_modules_ran; let errors = let unused_tests = List.filter (fun (_, _, used) -> not !used) which_tests.only_test_location in match unused_tests with | [] -> None | _ :: _ -> Some unused_tests in (match errors with | Some tests -> Printf.eprintf "ppx_inline_test error: the following -only-test flags matched nothing:"; List.iter (fun (filename, line_number_opt, _) -> match line_number_opt with | None -> Printf.eprintf " %s" filename | Some line_number -> Printf.eprintf " %s:%d" filename line_number) tests; Printf.eprintf ".\n%!"; Test_result.Error | None -> if !tests_ran = 0 && !strict then ( Printf.eprintf "ppx_inline_test error: no tests have been run.\n%!"; Test_result.Error) else Test_result.Success) | count, count_test_modules -> Printf.eprintf "FAILED %d / %d tests%s\n%!" count !tests_ran (if count_test_modules = 0 then "" else Printf.sprintf (", %d TES" ^^ "T_MODULES") count_test_modules); Test_result.Failure) ;; let use_color = !use_color let in_place = !in_place let diff_command = !diff_command let diff_path_prefix = !diff_path_prefix let source_tree_root = !source_tree_root let evaluators = ref [ summarize ] let add_evaluator ~f = evaluators := f :: !evaluators let exit () = List.map (fun f -> f ()) (List.rev !evaluators) |> Test_result.combine_all |> Test_result.to_exit_code |> exit ;; ppx_inline_test-0.16.1/runtime-lib/ppx_inline_test_lib.mli000066400000000000000000000030351450652077600240040ustar00rootroot00000000000000(** [am_running] is [true] if the code is running inline tests (e.g. [let%expect_test], [let%test], [let%test_unit]) or is in an executable invoked from inline tests. *) val am_running : bool val am_running_env_var : string (** [`Am_test_runner] means the [./inline_tests_runner] process, whereas [`Am_child_of_test_runner] means a process descended from the test runner. *) val testing : [ `Not_testing | `Testing of [ `Am_test_runner | `Am_child_of_test_runner ] ] (**/**) (** Everything below is for ppx or internal use *) module Test_result : sig type t = | Success | Failure | Error val combine : t -> t -> t val combine_all : t list -> t val to_string : t -> string end type config = (module Inline_test_config.S) type 'a test_function_args = config:config -> descr:string Lazy.t -> tags:string list -> filename:string -> line_number:int -> start_pos:int -> end_pos:int -> 'a val set_lib_and_partition : string -> string -> unit val unset_lib : string -> unit val test : ((unit -> bool) -> unit) test_function_args val test_unit : ((unit -> unit) -> unit) test_function_args val test_module : ((unit -> unit) -> unit) test_function_args val use_color : bool val in_place : bool val diff_command : string option val diff_path_prefix : string option val source_tree_root : string option (** Record an evaluator for an external set of tests *) val add_evaluator : f:(unit -> Test_result.t) -> unit (** Exit with a status based on the combined result of all recorded evaluators *) val exit : unit -> _ ppx_inline_test-0.16.1/src/000077500000000000000000000000001450652077600156065ustar00rootroot00000000000000ppx_inline_test-0.16.1/src/dune000066400000000000000000000011631450652077600164650ustar00rootroot00000000000000(library (name ppx_inline_test) (public_name ppx_inline_test) (kind (ppx_rewriter (cookies (inline_tests %{inline_tests})))) (ppx_runtime_libraries ppx_inline_test.config ppx_inline_test.runtime-lib) (libraries base ppxlib ppx_inline_test_libname) (preprocess (pps ppxlib.metaquot)) (inline_tests.backend (runner_libraries ppx_inline_test.runner.lib) (generate_runner (echo "let () = Ppx_inline_test_lib.exit ();;")) (list_partitions_flags "inline-test-runner" %{library-name} -list-partitions) (flags "inline-test-runner" %{library-name} -partition %{partition} -source-tree-root %{workspace_root} -diff-cmd -)))ppx_inline_test-0.16.1/src/ppx_inline_test.ml000066400000000000000000000220141450652077600213430ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default (* Generated code should depend on the environment in scope as little as possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It is especially important to not use polymorphic comparisons, since we are moving more and more to code that doesn't have them in scope. *) type maybe_drop = | Keep | Drop_with_deadcode | Drop let maybe_drop_mode = ref Keep let set_default_maybe_drop x = maybe_drop_mode := x let () = Driver.add_arg "-inline-test-drop" (Unit (fun () -> maybe_drop_mode := Drop)) ~doc:" Drop unit tests"; Driver.add_arg "-inline-test-drop-with-deadcode" (Unit (fun () -> maybe_drop_mode := Drop_with_deadcode)) ~doc: " Drop unit tests by wrapping them inside deadcode to prevent unused variable \ warnings." ;; let () = Driver.Cookies.add_simple_handler "inline-test" Ast_pattern.(pexp_ident (lident __')) ~f:(function | None -> () | Some id -> (match id.txt with | "drop" -> maybe_drop_mode := Drop | "drop_with_deadcode" -> maybe_drop_mode := Drop_with_deadcode | s -> Location.raise_errorf ~loc:id.loc "invalid 'inline-test' cookie (%s), expected one of: drop, \ drop_with_deadcode" s)) ;; (* Same as above, but for the Dune setting *) let () = Driver.Cookies.add_simple_handler "inline_tests" Ast_pattern.(estring __') ~f:(function | None -> () | Some id -> (match id.txt with | "enabled" -> maybe_drop_mode := Keep | "disabled" -> maybe_drop_mode := Drop | "ignored" -> maybe_drop_mode := Drop_with_deadcode | s -> Location.raise_errorf ~loc:id.loc "invalid 'inline_tests' cookie (%s), expected one of: enabled, disabled or \ ignored" s)) ;; let maybe_drop loc code = match !maybe_drop_mode with | Keep -> [%str let () = [%e code]] | Drop_with_deadcode -> [%str let () = if false then [%e code] else ()] | Drop -> Attribute.explicitly_drop#expression code; [%str] ;; let rec short_desc_of_expr ~max_len e = match e.pexp_desc with | Pexp_let (_, _, e) | Pexp_letmodule (_, _, e) -> short_desc_of_expr ~max_len e | _ -> let s = Pprintast.string_of_expression e in let res = if String.length s >= max_len then ( let s_short = String.sub s ~pos:0 ~len:(max_len - 5) in s_short ^ "[...]") else s in String.map res ~f:(function | '\n' -> ' ' | c -> c) ;; let descr ~(loc : Location.t) ?(inner_loc = loc) e_opt id_opt = let filename = loc.loc_start.pos_fname in let line = loc.loc_start.pos_lnum in let start_pos = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in let end_pos = inner_loc.Location.loc_end.pos_cnum - loc.loc_start.pos_bol in let descr = match id_opt with | `Literal id -> estring ~loc id | `Expr e -> e | `None -> estring ~loc (match e_opt with | None -> "" | Some e -> "<<" ^ short_desc_of_expr ~max_len:50 e ^ ">>") in ( pexp_lazy ~loc descr , estring ~loc filename , eint ~loc line , eint ~loc start_pos , eint ~loc end_pos ) ;; let apply_to_descr lid ~loc ?inner_loc e_opt id_opt tags more_arg = let descr, filename, line, start_pos, end_pos = descr ~loc ?inner_loc e_opt id_opt in let expr = pexp_apply ~loc (evar ~loc ("Ppx_inline_test_lib." ^ lid)) [ Labelled "config", [%expr (module Inline_test_config)] ; Labelled "descr", descr ; Labelled "tags", elist ~loc (List.map ~f:(estring ~loc) tags) ; Labelled "filename", filename ; Labelled "line_number", line ; Labelled "start_pos", start_pos ; Labelled "end_pos", end_pos ; Nolabel, more_arg ] in maybe_drop loc expr ;; let can_use_test_extensions () = match !maybe_drop_mode, Ppx_inline_test_libname.get () with | Keep, None -> false | (Drop | Drop_with_deadcode), _ | _, Some _ -> true ;; (* Set to [true] when we see a [let%test] or [let%expect_test] etc extension. *) module Has_tests = Driver.Create_file_property (struct let name = "ppx_inline_test.has_tests" end) (Bool) let all_tags = [ "no-js" ; "js-only" ; "64-bits-only" ; "32-bits-only" ; "fast-flambda" ; "x-library-inlining-sensitive" ; "not-on-el7" ; "not-on-el8" ; "disabled" ] ;; let validate_tag tag = if not (List.mem all_tags tag ~equal:String.equal) then Error (Spellcheck.spellcheck all_tags tag) else Ok () ;; let validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags = Has_tests.set true; if not (can_use_test_extensions ()) then Location.raise_errorf ~loc "%s: extension is disabled because the tests would be ignored (the build system \ didn't pass -inline-test-lib. With jenga or dune, this usually happens when \ writing tests in files that are part of an executable stanza, but only library \ stanzas support inline tests)" name_of_ppx_rewriter; List.iter tags ~f:(fun tag -> match validate_tag tag with | Ok () -> () | Error hint -> let hint = match hint with | None -> "" | Some hint -> "\n" ^ hint in Location.raise_errorf ~loc "%s: %S is not a valid tag for inline tests.%s" name_of_ppx_rewriter tag hint) ;; let name_of_ppx_rewriter = "ppx_inline_test" let expand_test ~loc ~path:_ ~name:id ~tags e = let loc = { loc with loc_ghost = true } in validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; apply_to_descr "test" ~loc (Some e) id tags [%expr fun () -> [%e e]] ;; let expand_test_unit ~loc ~path:_ ~name:id ~tags e = let loc = { loc with loc_ghost = true } in validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; (* The "; ()" bit is there to breaks tail call optimization, for better backtraces. *) apply_to_descr "test_unit" ~loc (Some e) id tags [%expr fun () -> [%e e]; ()] ;; let expand_test_module ~loc ~path:_ ~name:id ~tags m = let loc = { loc with loc_ghost = true } in validate_extension_point_exn ~name_of_ppx_rewriter ~loc ~tags; apply_to_descr "test_module" ~loc ~inner_loc:m.pmod_loc None id tags (pexp_fun ~loc Nolabel None (punit ~loc) (pexp_letmodule ~loc (Located.mk ~loc (Some "M")) m (eunit ~loc))) ;; module E = struct open Ast_pattern let tags = Attribute.declare "tags" Attribute.Context.pattern (single_expr_payload (pexp_tuple (many (estring __)) ||| map (estring __) ~f:(fun f x -> f [ x ]))) (fun x -> x) ;; let list_of_option = function | None -> [] | Some x -> x ;; let opt_name () = map (pstring __) ~f:(fun f x -> f (`Literal x)) ||| map ppat_any ~f:(fun f -> f `None) ||| map (ppat_extension (extension (cst ~to_string:Fn.id "name") (single_expr_payload __))) ~f:(fun f e -> f (`Expr e)) ;; let opt_name_and_expr expr = pstr (pstr_value nonrecursive (value_binding ~pat: (map (Attribute.pattern tags (opt_name ())) ~f:(fun f attributes name_opt -> f ~name:name_opt ~tags:(list_of_option attributes))) ~expr ^:: nil) ^:: nil) ;; let test = Extension.declare_inline "inline_test.test" Extension.Context.structure_item (opt_name_and_expr __) expand_test ;; let test_unit = Extension.declare_inline "inline_test.test_unit" Extension.Context.structure_item (opt_name_and_expr __) expand_test_unit ;; let test_module = Extension.declare_inline "inline_test.test_module" Extension.Context.structure_item (opt_name_and_expr (pexp_pack __)) expand_test_module ;; let all = [ test; test_unit; test_module ] end let tags = E.tags let () = Driver.V2.register_transformation "inline-test" ~extensions:E.all ~enclose_impl:(fun ctxt loc -> match loc, Ppx_inline_test_libname.get () with | None, _ | _, None -> [], [] | Some loc, Some (libname, partition_opt) -> let partition = match partition_opt with | None -> Stdlib.Filename.basename (Expansion_context.Base.input_name ctxt) | Some p -> p in let loc = { loc with loc_ghost = true } in (* See comment in benchmark_accumulator.ml *) let header = let loc = { loc with loc_end = loc.loc_start } in maybe_drop loc [%expr Ppx_inline_test_lib.set_lib_and_partition [%e estring ~loc libname] [%e estring ~loc partition]] and footer = let loc = { loc with loc_start = loc.loc_end } in maybe_drop loc [%expr Ppx_inline_test_lib.unset_lib [%e estring ~loc libname]] in header, footer) ;; ppx_inline_test-0.16.1/src/ppx_inline_test.mli000066400000000000000000000012101450652077600215070ustar00rootroot00000000000000open Ppxlib type maybe_drop = | Keep | Drop_with_deadcode | Drop (** How to expand tests if no "-inline-test-drop*" command line flag is passed. *) val set_default_maybe_drop : maybe_drop -> unit (** To be called on test extension points that use the ppx_inline_test runtime. Checks that tests are allowed with the given ppx command line, and that the tags are defined. *) val validate_extension_point_exn : name_of_ppx_rewriter:string -> loc:location -> tags:string list -> unit val maybe_drop : Location.t -> Parsetree.expression -> Parsetree.structure (**/**) val tags : (Parsetree.pattern, string list) Attribute.t ppx_inline_test-0.16.1/test/000077500000000000000000000000001450652077600157765ustar00rootroot00000000000000ppx_inline_test-0.16.1/test/config.ml000066400000000000000000000003701450652077600175750ustar00rootroot00000000000000let%test_module _ = (module struct let x = ref 0 let init = lazy (x := 42) module Inline_test_config = struct include Inline_test_config let pre_test_hook () = Lazy.force init end let%test _ = !x = 42 end) ;; ppx_inline_test-0.16.1/test/config.mli000066400000000000000000000000551450652077600177460ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/diff-with-without-partitions000066400000000000000000000011321450652077600234720ustar00rootroot00000000000000--- test.output +++ test-partitions.output @@ -1,3 +1,5 @@ +Test for partition config: +Test for partition failures: File "failures.ml", line 4, characters 0-18: <> is false. File "failures.ml", line 5, characters 0-29: name1 threw Exit. @@ -18,5 +20,10 @@ File "failures.ml", line 28, characters 0-30: name4 is false. -FAILED 6 / 28 tests, 2 TEST_MODULES +FAILED 6 / 6 tests, 2 TEST_MODULES code: 2 +Test for partition file_without_test_module: +Test for partition order: +Test for partition performance_test: +Test for partition random_state: +Test for partition unidiomatic_syntax: ppx_inline_test-0.16.1/test/disabled.ml000066400000000000000000000001431450652077600200750ustar00rootroot00000000000000(* Check that tests with the disabled tag are not run. *) let%test (_ [@tags "disabled"]) = false ppx_inline_test-0.16.1/test/disabled.mli000066400000000000000000000000551450652077600202500ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/drop.ml000066400000000000000000000002541450652077600172750ustar00rootroot00000000000000(* Check that ignored attributes inside dropped tests do not trigger an error *) let%test_module _ = (module struct [@@@attribute_not_handled_by_anything] end) ;; ppx_inline_test-0.16.1/test/drop.mli000066400000000000000000000000551450652077600174450ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/dune000066400000000000000000000032441450652077600166570ustar00rootroot00000000000000(library (name ppx_inline_test_lib_test) (preprocess (per_module ((pps ppx_inline_test) config disabled failures file_without_test_module order performance_test random_state unidiomatic_syntax) ((pps ppx_inline_test_drop) drop)))) (rule (targets test.output test-partitions.output test-inlining.output) (deps ./inline_tests_runner ./inline_tests_runner.exe) (action (bash "\ \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"))) (rule (targets diff-with-without-partitions) (deps ./test.output ./test-partitions.output) (action (bash "\ \ndiff -u --label test.output --label test-partitions.output test.output test-partitions.output > diff-with-without-partitions || true\ \n")) (mode fallback)) (rule (alias runtest) (deps test.expected test.output test-inlining.expected test-inlining.output) (action (bash "diff -u test.{expected,output}\ \n diff -u test-inlining.{expected,output}"))) (alias (name runtest) (deps diff-with-without-partitions))ppx_inline_test-0.16.1/test/failures.ml000066400000000000000000000007451450652077600201500ustar00rootroot00000000000000(* Checking failures are reported properly, and make the overall test fail. *) let%test _ = false let%test "name1" = raise Exit let%test_module "name2" = (module struct let%test _ = false let%test _ = false let%test _ = raise Exit let%test_module "name3" = (module struct let () = raise Exit end) ;; end) ;; let%test_module _ = (module struct let () = raise Exit end) ;; let x, y = "name", "4" let%test [%name x ^ y] = false ppx_inline_test-0.16.1/test/failures.mli000066400000000000000000000000551450652077600203130ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/file_without_test_module.ml000066400000000000000000000000221450652077600234300ustar00rootroot00000000000000let%test _ = true ppx_inline_test-0.16.1/test/file_without_test_module.mli000066400000000000000000000000551450652077600236070ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/order.ml000066400000000000000000000017361450652077600174520ustar00rootroot00000000000000(* checking that the execution order is right (and that tests do run) *) let count = ref 0 let check i = assert ( match Sys.getenv "DONT_ASSUME_ALL_TESTS_RUN" with | (_ : string) -> true | exception Not_found -> !count = i); incr count ;; module F (X : sig val start : int end) = struct let () = check X.start let%test_unit _ = check (X.start + 1) let () = check (X.start + 2) end let () = check 0 let%test_unit _ = check 1 let () = check 2 let%test _ = check 3; true ;; let () = check 4 let%test_module _ = (module struct let () = check 5 let%test_unit _ = check 6 let () = check 7 let%test _ = check 8; true ;; let%test_module _ = (module struct let () = check 9 module _ = F (struct let start = 10 end) let () = check 13 end) ;; module _ = F (struct let start = 14 end) let () = check 17 end) ;; let () = check 18 ppx_inline_test-0.16.1/test/order.mli000066400000000000000000000000551450652077600176140ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/performance_test.ml000066400000000000000000000015051450652077600216710ustar00rootroot00000000000000let%test ("alloc-test-ok" [@tags "x-library-inlining-sensitive"]) = true (* Let's just pretend we have a test, say an alloc test, that only works with inlining, and is currently broken. *) let%test ("alloc-test-fail" [@tags "x-library-inlining-sensitive"]) = false let%test_module "alloc-test-module2" = (module struct let%test _ = true let%test (_ [@tags "x-library-inlining-sensitive"]) = true end) ;; let%test_module ("alloc-test-module" [@tags "x-library-inlining-sensitive"]) = (module struct let%test "ok" = true let%test "fail" = false end) ;; let%test_module ("early-cutoff-module" [@tags "x-library-inlining-sensitive"]) = (module struct (* the toplevel of this module should not even be run when we aren't running the inlining-sensitive tests. *) let () = assert false end) ;; ppx_inline_test-0.16.1/test/performance_test.mli000066400000000000000000000000551450652077600220410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/random_state.ml000066400000000000000000000020731450652077600210120ustar00rootroot00000000000000let test list = ListLabels.iter list ~f:(fun expect -> let actual = Random.int 1000 in if actual <> expect then failwith (Printf.sprintf "%d <> %d" actual expect)) ;; (* Random state is repeatable: *) let in_fresh_inline_test = [ 220; 256; 600 ] let%test_unit _ = test in_fresh_inline_test let%test_unit _ = test in_fresh_inline_test let%test_unit _ = test in_fresh_inline_test (* Random state can be overridden: *) let after_random_init_0 = [ 752; 190; 154 ] let%test_unit _ = Random.init 0; test after_random_init_0 ;; let%test_unit _ = Random.init 0; test after_random_init_0 ;; let%test_unit _ = Random.init 0; test after_random_init_0 ;; (* Tests inside a functor restore the existing random state after they run: *) module Make () = struct let%test_unit _ = () end let%test_unit _ = Random.init 0; let module _ = Make () in test after_random_init_0 ;; let%test_unit _ = Random.init 0; let module _ = Make () in test after_random_init_0 ;; let%test_unit _ = Random.init 0; let module _ = Make () in test after_random_init_0 ;; ppx_inline_test-0.16.1/test/random_state.mli000066400000000000000000000000551450652077600211610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_inline_test-0.16.1/test/test-inlining.expected000066400000000000000000000022341450652077600223060ustar00rootroot00000000000000Partitions diff: 2a3 > file_without_test_module 4a6,7 > random_state > unidiomatic_syntax File "performance_test.ml", line 1, characters 0-72: alloc-test-ok (XXX sec) File "performance_test.ml", line 5, characters 0-75: alloc-test-fail (XXX sec) File "performance_test.ml", line 10, characters 4-62: <> (XXX sec) File "performance_test.ml", line 16, characters 4-24: ok (XXX sec) File "performance_test.ml", line 17, characters 4-27: fail (XXX sec) ====================================================================== TEST_MODULE at file "failures.ml", line 13, characters 4-88: name3 threw Exit. in TEST_MODULE at file "failures.ml", line 7, characters 0-220: name2 TEST_MODULE at file "failures.ml", line 21, characters 0-66 threw Exit. File "performance_test.ml", line 5, characters 0-75: alloc-test-fail is false. File "performance_test.ml", line 17, characters 4-27: fail is false. in TEST_MODULE at file "performance_test.ml", line 14, characters 0-154: alloc-test-module TEST_MODULE at file "performance_test.ml", line 21, characters 0-250: early-cutoff-module threw "Assert_failure performance_test.ml:25:13". FAILED 2 / 5 tests, 3 TEST_MODULES code: 2 ppx_inline_test-0.16.1/test/test.expected000066400000000000000000000015651450652077600205070ustar00rootroot00000000000000File "failures.ml", line 4, characters 0-18: <> is false. File "failures.ml", line 5, characters 0-29: name1 threw Exit. File "failures.ml", line 9, characters 4-22: <> is false. in TEST_MODULE at file "failures.ml", line 7, characters 0-220: name2 File "failures.ml", line 10, characters 4-22: <> is false. in TEST_MODULE at file "failures.ml", line 7, characters 0-220: name2 File "failures.ml", line 11, characters 4-27: <> threw Exit. in TEST_MODULE at file "failures.ml", line 7, characters 0-220: name2 TEST_MODULE at file "failures.ml", line 13, characters 4-88: name3 threw Exit. in TEST_MODULE at file "failures.ml", line 7, characters 0-220: name2 TEST_MODULE at file "failures.ml", line 21, characters 0-66 threw Exit. File "failures.ml", line 28, characters 0-30: name4 is false. FAILED 6 / 28 tests, 2 TEST_MODULES code: 2 ppx_inline_test-0.16.1/test/unidiomatic_syntax.ml000066400000000000000000000000311450652077600222350ustar00rootroot00000000000000[%%test_unit let _ = ()] ppx_inline_test-0.16.1/test/unidiomatic_syntax.mli000066400000000000000000000000551450652077600224140ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)