diff options
| author | Julien Puydt <jpuydt@debian.org> | 2023-06-21 15:38:45 +0200 |
|---|---|---|
| committer | Julien Puydt <jpuydt@debian.org> | 2023-06-21 15:38:45 +0200 |
| commit | 0354d5e7b8c3dbd812feebfdf69307683d4cd421 (patch) | |
| tree | 705be1bfa068f5d0122dec6ab042f4ccdd089e77 | |
Import ppx-expect_0.16.0.orig.tar.gz
[dgit import orig ppx-expect_0.16.0.orig.tar.gz]
157 files changed, 5959 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6c14091 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +_build +*.install +*.merlin +_opam + diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..81c8f73 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,151 @@ +## Release v0.16.0 + +* Made `[%expect]` blocks always have type `unit`. Removed the need for monadic flush + operations. Expect tests inside concurrent frameworks like `Async` now expect output + during testing to be synchronous, or manually flushed. `Async` has, for some time, used + synchronous i/o for stdout and stderr when running expect tests. + +* Moved corrected-file generation to a library `Make_corrected_file`. This allows expect + tests and other testing tools to share a method for writing out corrected files and + printing out errors for corrections. + +## Old pre-v0.15 changelogs (very likely stale and incomplete) + +## git version + + +- Make sure the code we generate can be typed without warning when `-principal` + is passed to the compiler. + +## v0.11 + +- Change `ppx_expect` so that when `-diff-cmd -` is passed, they write the + .corrected file but don't diff it or exit with a non-zero exit code. + + This is to make expect tests work with jbuilder. Jbuilder uses a separate + build tree, so the current behavior of `ppx_expect` doesn't work well with + jbuilder, especially the in-place behavior. + + What is done instead in jbuilder is that after running the test runner, it + checks whether a .corrected file was created. If yes, jbuilder does the + diffing itself, and by default also replaces the source file by the + correction.' + +- Regexp and glob matching in the output is now deprecated. This gets in the + way of the "promote" workflow. + People are instead encouraged to prefilter the output before displaying it. + +- Tell the build system via output metadata whether a file contains + tests or not + +- Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, + ppx\_metaquot, ppx\_traverse and ppx\_type\_conv. + +## v0.10 + +- In `[%expect]` expressions, disallowed backtraces, which can vary across + compilation configurations (X_LIBRARY_INLINING, flambda, etc.) + +- Improved `ppx_expect` to support simultaneous runs of `inline_tests_runner` on + the same file. + +- Added expect-test support for reaching a single `[%expect]` multiple times, + where the test only fails if the output was distinct + +- For expect tests, relaxed the rule for `%expects` that are reached multiple + times. Instead of requiring all outputs to be identical, require only that + each output individually match the `%expect`. + +- In synchronous expect tests, `[%expect]` now captures stderr in addition to + stdout. Previously, there was code that did this for Async expect tests. Now, + stderr is captured in all expect tests. + +- Improved expect tests to get the current file when the test runs, rather than + when it is registered. + +## v0.9 + +## 113.43.00 + +- Always flush Pervasives.stdout in the ppx_expect runtime. + + We already do this, but it was missing in one place. + +- Made the test framework resilient to user changing the current working directory during the test. + +- Print newlines in `"`-strings as real newlines, not `\n` + +- The expect test runtime breaks any executable that wants to work even if + cwd doesn't exist, like fe does. Fix that. + + It also brings expect tests in line with what ppx\_inline\_test does, and removes the diff + due to absolute paths I was seeing in the output of `./inline_tests_runner -log` in some + other features. Concretely, here is what changes: + +- Use the new context-free API + +- Change the check in ppx\_expect to be a dynamic check. Instead of + checking that expect tests appears only at toplevel, we test that + they are run in the library they appear. + + This has several consquence: + + - ppx\_expect can use `Context_free` as well and doesn't require two extra passes + - expect tests can appear inside let%test_module + +## 113.33.01 + +- Add dependency on `re.emacs` + +## 113.33.00 + +- Don't remove trailing semicolons when producing a correction. + +- Corrected `%expect`s with double quoted strings don't have the single space padding. + +- In the ppx\_expect runtime, flush stdout before redirecting it + This is to avoid capturing leftover of the stdout buffer. + +- Make sure the expect-test runtime doesn't generate + `%collector_never_triggered`, which is not accepted by ppx\_expect. + Instead generate: + + `%expect {| DID NOT REACH THIS PROGRAM POINT |}` + +- Make expect tests pass the user description to the inline test runtime + +- Fix a race condition in the ppx\_expect runtime + + +- Change ppx\_expect be more permissive when matching whitespace in actual output. + See `ppx/ppx_expect/README.org` for details. + + Changes to the implementation of ppx\_expect (including some refactoring): + - factorized the common bits between the runtime and ppx rewriter + into one library expect_test_common + - factorized different structures representing the same thing using polymorphism + - communicate data structures between the ppx rewriter and runtime + using a generated lifter instead of hand-written lifters + - splitted the matching and correction writing code: the .corrected is + now only created when needed instead of all the time + - added a concrete syntax tree to represent both the actual output and + expectation in non-exact mode. + This allow to keep the user formatting as much as possible + - made various bits more re-usable + +- Change the default style of multi-line expectation to: + + `%expect {| + abc + def |}` + + More generally, try to preserve the formatting a bit more when + correcting from empty or single to multi-line. + +- Arrange things so that when `open Async.Std` is opened, `%expect ...` + expressions are of type `unit Deferred.t` and flush stdout before + capturing the output. + +## 113.24.00 + +Initial release. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..45e1a22 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,67 @@ +This 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 <joe.smith@email.com> +``` + +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/ diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..e74598f --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2015--2023 Jane Street Group, LLC <opensource-contacts@janestreet.com> + +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. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..1965878 --- /dev/null +++ b/Makefile @@ -0,0 +1,17 @@ +INSTALL_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 diff --git a/README.org b/README.org new file mode 100644 index 0000000..a1737e2 --- /dev/null +++ b/README.org @@ -0,0 +1,287 @@ +#+TITLE: expect-test - a cram like framework for OCaml + +** Introduction + +Expect-test is a framework for writing tests in OCaml, similar to [[https://bitheap.org/cram/][Cram]]. +Expect-tests mimic the existing inline tests framework with the =let%expect_test= construct. +The body of an expect-test can contain output-generating code, interleaved with =%expect= extension +expressions to denote the expected output. + +When run, these tests will pass iff the output matches what was expected. If a test fails, a +corrected file with the suffix ".corrected" will be produced with the actual output, and the +=inline_tests_runner= will output a diff. + +Here is an example Expect-test program, say in =foo.ml= + +#+begin_src ocaml +open Core + +let%expect_test "addition" = + printf "%d" (1 + 2); + [%expect {| 4 |}] +#+end_src + +When the test is run (as part of =inline_tests_runner=), =foo.ml.corrected= will be produced with the +contents: + +#+begin_src ocaml +open Core + +let%expect_test "addition" = + printf "%d" (1 + 2); + [%expect {| 3 |}] +#+end_src + +=inline_tests_runner= will also output the diff: + +#+begin_src +---foo.ml ++++foo.ml.corrected +File "foo.ml", line 5, characters 0-1: + open Core + + let%expect_test "addition" = + printf "%d" (1 + 2); +-| [%expect {| 4 |}] ++| [%expect {| 3 |}] +#+end_src + +Diffs will be shown in color if the =-use-color= flag is passed to the test runner executable. + +** Expects reached from multiple places + +A [%expect] can exist in a way that it is encountered multiple times, e.g. in a +functor or a function: + +#+begin_src ocaml +let%expect_test _ = + let f output = + print_string output; + [%expect {| hello world |}] + in + f "hello world"; + f "hello world"; +;; +#+end_src + +The =[%expect]= should capture the exact same output (i.e. up to string equality) at every +invocation. In particular, this does **not** work: + +#+begin_src ocaml +let%expect_test _ = + let f output = + print_string output; + [%expect {| \(foo\|bar\) (regexp) |}] + in + f "foo"; + f "bar"; +;; +#+end_src + +** Output matching + +Matching is done on a line-by-line basis. If any output line fails to +match its expected output, the expected line is replaced with the +actual line in the final output. + +*** Whitespace + +Inside =%expect= nodes, whitespace around patterns are ignored, and +the user is free to put any amount for formatting purposes. The same +goes for the actual output. + +Ignoring surrounding whitespace allows to write nicely formatted +expectation and focus only on matching the bits that matter. + +To do this, ppx_expect strips patterns and outputs by taking the +smallest rectangle of text that contains the non-whitespace +material. All end of line whitespace are ignored as well. So for +instance all these lines are equivalent: + +#+begin_src ocaml + print blah; + [%expect {| +abc +defg + hij|}] + + print blah; + [%expect {| + abc + defg + hij + |}] + + print blah; + [%expect {| + abc + defg + hij + |}] +#+end_src + +However, the last one is nicer to read. + +For the rare cases where one does care about what the exact output is, +ppx_expect provides the =%expect_exact= extension point, which only +succeed when the untouched output is exactly equal to the untouched +pattern. + +When producing a correction, ppx_expect tries to respect as much as +possible the formatting of the pattern. + +** Output capture + +The extension point =[%expect.output]= returns a =string= with the output that +would have been matched had an =[%expect]= node been there instead. + +An idiom for testing non-deterministic output is to capture the output using +=[%expect.output]= and either post-process it or inspect it manually, e.g., + +#+BEGIN_SRC ocaml +show_process (); +let pid_and_exit_status = [%expect.output] in +let exit_status = discard_pid pid_and_exit_status in +print_endline exit_status; +[%expect {| 1 |}] +#+END_SRC + +This is preferred over output patterns (see below). + +** Integration with Async, Lwt or other cooperative libraries + +If you are writing expect tests for a system using Async, Lwt or any +other libraries for cooperative threading, you need some preparation +so that everything works well. For instance, you probably need to +flush some =stdout= channel. The expect test runtime takes care of +flushing =Stdlib.stdout= but it doesn't know about +=Async.Writer.stdout=, =Lwt_io.stdout= or anything else. + +To deal with this, expect\_test provides some hooks in the form of a +configuration module =Expect_test_config=. The default module in scope +define no-op hooks that the user can override. =Async= redefines +this module so when =Async= is opened you can write async-aware +expect test. + +In addition to =Async.Expect_test_config=, there is an +alternative, =Async.Expect_test_config_with_unit_expect=. That is +easier to use than =Async.Expect_test_config= because =[%expect]= has +type =unit= rather than =unit Deferred.t=. So one can write: + +#+begin_src ocaml +[%expect foo]; +#+end_src + +rather than: + +#+begin_src ocaml +let%bind () = [%expect foo] in +#+end_src + +=Expect_test_config_with_unit_expect= arrived in 2019-06. We hope to +transition from =Expect_test_config= to +=Expect_test_config_with_unit_expect=, eventually renaming the latter +as the former. + +*** LWT + +This is what you would need to write expect tests with Lwt: + +#+begin_src ocaml +module Lwt_io_run = struct + type 'a t = 'a Lwt.t +end + +module Lwt_io_flush = struct + type 'a t = 'a Lwt.t + let return x = Lwt.return x + let bind x ~f = Lwt.bind x f + let to_run x = x +end + +module Expect_test_config : + Expect_test_config_types.S + with module IO_run = Lwt_io_run + and module IO_flush = Lwt_io_flush = struct + module IO_run = Lwt_io_run + module IO_flush = Lwt_io_flush + let run x = Lwt_main.run (x ()) + let upon_unreleasable_issue = `CR +end +#+end_src + +** Comparing Expect-test and unit testing (e.g. =let%test_unit=) + +The simple example above can be easily represented as a unit test: + +#+begin_src ocaml +let%test_unit "addition" = [%test_result: int] (1 + 2) ~expect:4 +#+end_src + +So, why would one use Expect-test rather than a unit test? There are +several differences between the two approaches. + +With a unit test, one must write code that explicitly checks that the +actual behavior agrees with the expected behavior. =%test_result= is +often a convenient way of doing that, but even using that requires: + +- creating a value to compare +- writing the type of that value +- having a comparison function on the value +- writing down the expected value + +With Expect-test, we can simply add print statements whose output gives +insight into the behavior of the program, and blank =%expect= +attributes to collect the output. We then run the program to see if +the output is acceptable, and if so, *replace* the original program +with its output. E.g we might first write our program like this: + +#+begin_src ocaml +let%expect_test _ = + printf "%d" (1 + 2); + [%expect {||}] +#+end_src + +The corrected file would contain: + +#+begin_src ocaml +let%expect_test _ = + printf "%d" (1 + 2); + [%expect {| 3 |}] +#+end_src + +With Expect-test, we only have to write code that prints things that we +care about. We don't have to construct expected values or write code +to compare them. We get comparison for free by using diff on the +output. And a good diff (e.g. patdiff) can make understanding +differences between large outputs substantially easier, much easier +than typical unit-testing code that simply states that two values +aren't equal. + +Once an Expect-test program produces the desired expected output and we +have replaced the original program with its output, we now +automatically have a regression test going forward. Any undesired +change to the output will lead to a mismatch between the source +program and its output. + +With Expect-test, the source program and its output are interleaved. This +makes debugging easier, because we do not have to jump between source +and its output and try to line them up. Furthermore, when there is a +mismatch, we can simply add print statements to the source program and +run it again. This gives us interleaved source and output with the +debug messages interleaved in the right place. We might even insert +additional empty =%%expect= attributes to collect debug messages. + +** Implementation + +Every =%expect= node in an Expect-test program becomes a point at which +the program output is captured. Once the program terminates, the +captured outputs are matched against the expected outputs, and interleaved with +the original source code to produce the corrected file. Trailing output is appended in a +new =%expect= node. + +** Build system integration + +Follow the same rules as for [[https://github.com/janestreet/ppx_inline_test][ppx_inline_test]]. Just make sure to +include =ppx_expect.evaluator= as a dependency of the test runner. The +[[https://github.com/janestreet/jane-street-tests][Jane Street tests]] contains a few working examples using oasis. diff --git a/collector/check_backtraces.mli b/collector/check_backtraces.mli new file mode 100644 index 0000000..a1fa6c5 --- /dev/null +++ b/collector/check_backtraces.mli @@ -0,0 +1 @@ +val contains_backtraces : string -> bool diff --git a/collector/check_backtraces.mll b/collector/check_backtraces.mll new file mode 100644 index 0000000..2f61ed8 --- /dev/null +++ b/collector/check_backtraces.mll @@ -0,0 +1,14 @@ +let forbidden = "Raised at " | "Called from " | "Raised by primitive operation " + +rule check = parse + | forbidden { true } + | "" { not_at_bos lexbuf } + +and not_at_bos = parse + | [^'a'-'z' 'A'-'Z' '0'-'9' '_'] forbidden { true } + | _ { not_at_bos lexbuf } + | eof { false } + +{ + let contains_backtraces s = check (Lexing.from_string s) +} diff --git a/collector/dune b/collector/dune new file mode 100644 index 0000000..51954de --- /dev/null +++ b/collector/dune @@ -0,0 +1,8 @@ +(library (name expect_test_collector) (public_name ppx_expect.collector) + (synopsis "Runtime library for ppx_expect") + (libraries expect_test_common expect_test_config_types + ppx_inline_test.runtime-lib) + (c_names expect_test_collector_stubs) + (js_of_ocaml (javascript_files runtime.js)) (preprocess no_preprocessing)) + +(ocamllex check_backtraces)
\ No newline at end of file diff --git a/collector/expect_test_collector.ml b/collector/expect_test_collector.ml new file mode 100644 index 0000000..be3e9b0 --- /dev/null +++ b/collector/expect_test_collector.ml @@ -0,0 +1,297 @@ +open Expect_test_common +module List = ListLabels + +module Test_outcome = struct + type t = + { file_digest : File.Digest.t + ; location : File.Location.t + ; expectations : Expectation.Raw.t list + ; uncaught_exn_expectation : Expectation.Raw.t option + ; saved_output : (File.Location.t * string) list + ; trailing_output : string + ; upon_unreleasable_issue : Expect_test_config_types.Upon_unreleasable_issue.t + ; uncaught_exn : (exn * Printexc.raw_backtrace) option + } +end + +let tests_run : Test_outcome.t list ref = ref [] + +let protect ~finally ~f = + match f () with + | x -> + finally (); + x + | exception e -> + finally (); + raise e +;; + +module Current_file = struct + let current = ref None + + let set ~absolute_filename = + match !current with + | None -> current := Some absolute_filename + | Some _ -> failwith "Expect_test_collector.set: already set" + ;; + + let unset () = + match !current with + | Some _ -> current := None + | None -> failwith "Expect_test_collector.unset: not set" + ;; + + let get () = + match !current with + | Some fn -> fn + | None -> failwith "Expect_test_collector.get: not set" + ;; +end + +module Instance = struct + type t = + { mutable saved : (File.Location.t * int) list + ; chan : out_channel + ; filename : File.Name.t + } + + external before_test + : output:out_channel + -> stdout:out_channel + -> stderr:out_channel + -> unit + = "expect_test_collector_before_test" + + external after_test + : stdout:out_channel + -> stderr:out_channel + -> unit + = "expect_test_collector_after_test" + + external pos_out : out_channel -> int = "caml_out_channel_pos_fd" + + let get_position () = pos_out stdout + + let create () = + let filename = Filename.temp_file "expect-test" "output" in + let chan = open_out_bin filename in + before_test ~output:chan ~stdout ~stderr; + { chan; filename = File.Name.of_string filename; saved = [] } + ;; + + let relative_filename t = File.Name.relative_to ~dir:(File.initial_dir ()) t.filename + + let with_ic fname ~f = + let ic = open_in_bin fname in + protect ~finally:(fun () -> close_in ic) ~f:(fun () -> f ic) + ;; + + let current_test : (File.Location.t * t) option ref = ref None + let am_running_expect_test () = Option.is_some !current_test + + let get_current () = + match !current_test with + | Some (_, t) -> t + | None -> failwith "Expect_test_collector.Instance.get_current called outside a test." + ;; + + let save_output_without_flush t location = + let pos = get_position () in + t.saved <- (location, pos) :: t.saved + ;; + + let save_and_return_output_without_flush t location = + let pos = get_position () in + let prev_pos = + match t.saved with + | [] -> 0 + | (_, prev_pos) :: _ -> prev_pos + in + t.saved <- (location, pos) :: t.saved; + flush t.chan; + let len = pos - prev_pos in + with_ic (relative_filename t) ~f:(fun ic -> + seek_in ic prev_pos; + really_input_string ic len) + ;; +end + +let am_running_expect_test = Instance.am_running_expect_test + +let flush () = + Format.pp_print_flush Format.std_formatter (); + Format.pp_print_flush Format.err_formatter (); + Stdlib.flush Stdlib.stdout; + Stdlib.flush Stdlib.stderr +;; + +let save_and_return_output location = + let instance = Instance.get_current () in + flush (); + Instance.save_and_return_output_without_flush instance location +;; + +module Make (C : Expect_test_config_types.S) = struct + module Instance_io : sig + val save_output : File.Location.t -> unit + val save_and_return_output : File.Location.t -> string + + val exec + : file_digest:File.Digest.t + -> location:File.Location.t + -> expectations:Expectation.Raw.t list + -> uncaught_exn_expectation:Expectation.Raw.t option + -> f:(unit -> unit C.IO.t) + -> unit + end = struct + open Instance + + let extract_output_and_sanitize ic len = + let s = really_input_string ic len |> C.sanitize in + if not (Check_backtraces.contains_backtraces s) + then s + else + Expect_test_config_types.Upon_unreleasable_issue + .message_when_expectation_contains_backtrace + C.upon_unreleasable_issue + ^ s + ;; + + let get_outputs_and_cleanup t = + Sys.chdir (File.initial_dir ()); + let last_ofs = get_position () in + after_test ~stdout ~stderr; + close_out t.chan; + let fname = relative_filename t in + protect + ~finally:(fun () -> Sys.remove fname) + ~f:(fun () -> + with_ic fname ~f:(fun ic -> + let ofs, outputs = + List.fold_left + (List.rev t.saved) + ~init:(0, []) + ~f:(fun (ofs, acc) (loc, next_ofs) -> + let s = extract_output_and_sanitize ic (next_ofs - ofs) in + next_ofs, (loc, s) :: acc) + in + let trailing_output = extract_output_and_sanitize ic (last_ofs - ofs) in + List.rev outputs, trailing_output)) + ;; + + let save_output location = + let t = get_current () in + flush (); + save_output_without_flush t location + ;; + + let save_and_return_output location = + let t = get_current () in + flush (); + save_and_return_output_without_flush t location + ;; + + let () = + Stdlib.at_exit (fun () -> + match !current_test with + | None -> () + | Some (loc, t) -> + let blocks, trailing = get_outputs_and_cleanup t in + Printf.eprintf + "File %S, line %d, characters %d-%d:\n\ + Error: program exited while expect test was running!\n\ + Output captured so far:\n\ + %!" + (File.Name.to_string loc.filename) + loc.line_number + (loc.start_pos - loc.line_start) + (loc.end_pos - loc.line_start); + List.iter blocks ~f:(fun (_, s) -> Printf.eprintf "%s%!" s); + Printf.eprintf "%s%!" trailing) + ;; + + let exec ~file_digest ~location ~expectations ~uncaught_exn_expectation ~f = + let t = create () in + current_test := Some (location, t); + let finally uncaught_exn = + C.run (fun () -> + C.IO.return + (flush (); + current_test := None; + let saved_output, trailing_output = get_outputs_and_cleanup t in + tests_run + := { file_digest + ; location + ; expectations + ; uncaught_exn_expectation + ; saved_output + ; trailing_output + ; upon_unreleasable_issue = C.upon_unreleasable_issue + ; uncaught_exn + } + :: !tests_run)) + in + match C.run f with + | () -> finally None + | exception exn -> + let bt = Printexc.get_raw_backtrace () in + finally (Some (exn, bt)) + ;; + end + + let save_output = Instance_io.save_output + let save_and_return_output = Instance_io.save_and_return_output + + let run + ~file_digest + ~(location : File.Location.t) + ~absolute_filename:defined_in + ~description + ~tags + ~expectations + ~uncaught_exn_expectation + ~inline_test_config + f + = + Ppx_inline_test_lib.test + ~config:inline_test_config + ~descr: + (lazy + (match description with + | None -> "" + | Some s -> s)) + ~tags + ~filename:(File.Name.to_string location.filename) + ~line_number:location.line_number + ~start_pos:(location.start_pos - location.line_start) + ~end_pos:(location.end_pos - location.line_start) + (fun () -> + let registering_tests_for = Current_file.get () in + if defined_in <> registering_tests_for + then + Printf.ksprintf + failwith + "Trying to run an expect test from the wrong file.\n\ + - test declared at %s:%d\n\ + - trying to run it from %s\n" + defined_in + location.line_number + registering_tests_for + else ( + (* To avoid capturing not-yet flushed data of the stdout buffer *) + C.run (fun () -> C.IO.return (flush ())); + Instance_io.exec + ~file_digest + ~location + ~expectations + ~uncaught_exn_expectation + ~f; + true)) + ;; +end +[@@inline never] + +let tests_run () = + (* We prepend tests when we encounter them, so reverse the list to reinstate order *) + List.rev !tests_run +;; diff --git a/collector/expect_test_collector.mli b/collector/expect_test_collector.mli new file mode 100644 index 0000000..029ba07 --- /dev/null +++ b/collector/expect_test_collector.mli @@ -0,0 +1,53 @@ +open Expect_test_common + +module Test_outcome : sig + type t = + { file_digest : File.Digest.t + ; location : File.Location.t + ; expectations : Expectation.Raw.t list + ; uncaught_exn_expectation : Expectation.Raw.t option + ; saved_output : (File.Location.t * string) list + ; trailing_output : string + ; upon_unreleasable_issue : Expect_test_config_types.Upon_unreleasable_issue.t + ; uncaught_exn : (exn * Printexc.raw_backtrace) option + } +end + +module Make (Config : Expect_test_config_types.S) : sig + (** Collect the output that has been run since the last call to [save_output], or + since the current expect-test started running. + + This function should only be called while a test is running. It is meant to be + called as a result of ppx_expect translating an expect-test, and is not intended + to be called manually. *) + val save_output : File.Location.t -> unit + + val save_and_return_output : File.Location.t -> string + + (** Run an expect-test *) + val run + : file_digest:File.Digest.t + -> location:File.Location.t + -> absolute_filename:string + -> description:string option + -> tags:string list + -> expectations:Expectation.Raw.t list + -> uncaught_exn_expectation:Expectation.Raw.t option + -> inline_test_config:Ppx_inline_test_lib.config + -> (unit -> unit Config.IO.t) + -> unit +end + +(** Returns true if and only if an expect test is currently collecting output. *) +val am_running_expect_test : unit -> bool + +(** Flushes stdout/stderr. Same as [Make().save_and_return_output], without monad. *) +val save_and_return_output : File.Location.t -> string + +(** The tests that ran, in the order they ran *) +val tests_run : unit -> Test_outcome.t list + +module Current_file : sig + val set : absolute_filename:string -> unit + val unset : unit -> unit +end diff --git a/collector/expect_test_collector_stubs.c b/collector/expect_test_collector_stubs.c new file mode 100644 index 0000000..135e424 --- /dev/null +++ b/collector/expect_test_collector_stubs.c @@ -0,0 +1,107 @@ +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> +#ifndef _MSC_VER +#include <unistd.h> +#endif + +/* #include <caml/io.h> */ + +/* The definition of channel should be kept in sync with upstream ocaml */ +/* Start of duplicated code from caml/io.h */ +#ifndef IO_BUFFER_SIZE +#define IO_BUFFER_SIZE 65536 +#endif + +#if defined(_WIN32) +typedef __int64 file_offset; +#elif defined(HAS_OFF_T) +#include <sys/types.h> +typedef off_t file_offset; +#else +typedef long file_offset; +#endif + +struct channel { + int fd; /* Unix file descriptor */ + file_offset offset; /* Absolute position of fd in the file */ + char *end; /* Physical end of the buffer */ + char *curr; /* Current position in the buffer */ + char *max; /* Logical end of the buffer (for input) */ + void *mutex; /* Placeholder for mutex (for systhreads) */ + struct channel *next, *prev; /* Double chaining of channels (flush_all) */ + int revealed; /* For Cash only */ + int old_revealed; /* For Cash only */ + int refcount; /* For flush_all and for Cash */ + int flags; /* Bitfield */ + char buff[IO_BUFFER_SIZE]; /* The buffer itself */ + char *name; /* Optional name (to report fd leaks) */ +}; + +#define Channel(v) (*((struct channel **)(Data_custom_val(v)))) + +/* End of duplicated code from caml/io.h */ + +/* Start of duplicated code from caml/sys.h */ +#define NO_ARG Val_int(0) +CAMLextern void caml_sys_error(value); +/* End of duplicated code from caml/sys.h */ + +static int expect_test_collector_saved_stdout; +static int expect_test_collector_saved_stderr; + +CAMLprim value expect_test_collector_before_test(value voutput, value vstdout, + value vstderr) { + struct channel *output = Channel(voutput); + struct channel *cstdout = Channel(vstdout); + struct channel *cstderr = Channel(vstderr); + int fd, ret; + fd = dup(cstdout->fd); + if (fd == -1) + caml_sys_error(NO_ARG); + expect_test_collector_saved_stdout = fd; + fd = dup(cstderr->fd); + if (fd == -1) + caml_sys_error(NO_ARG); + expect_test_collector_saved_stderr = fd; + ret = dup2(output->fd, cstdout->fd); + if (ret == -1) + caml_sys_error(NO_ARG); + ret = dup2(output->fd, cstderr->fd); + if (ret == -1) + caml_sys_error(NO_ARG); + return Val_unit; +} + +CAMLprim value expect_test_collector_after_test(value vstdout, value vstderr) { + struct channel *cstdout = Channel(vstdout); + struct channel *cstderr = Channel(vstderr); + int ret; + ret = dup2(expect_test_collector_saved_stdout, cstdout->fd); + if (ret == -1) + caml_sys_error(NO_ARG); + ret = dup2(expect_test_collector_saved_stderr, cstderr->fd); + if (ret == -1) + caml_sys_error(NO_ARG); + ret = close(expect_test_collector_saved_stdout); + if (ret == -1) + caml_sys_error(NO_ARG); + ret = close(expect_test_collector_saved_stderr); + if (ret == -1) + caml_sys_error(NO_ARG); + return Val_unit; +} + +CAMLprim value caml_out_channel_pos_fd(value vchan) { + struct channel *chan = Channel(vchan); + file_offset ret; + caml_enter_blocking_section(); + ret = lseek(chan->fd, 0, SEEK_CUR); + caml_leave_blocking_section(); + if (ret == -1) + caml_sys_error(NO_ARG); + if (ret > Max_long) + caml_failwith("caml_out_channel_pos_fd: overflow"); + return Val_long(ret); +} diff --git a/collector/runtime.js b/collector/runtime.js new file mode 100644 index 0000000..5fdf1d9 --- /dev/null +++ b/collector/runtime.js @@ -0,0 +1,32 @@ +//Provides: expect_test_collector_saved_stdout +var expect_test_collector_saved_stdout +//Provides: expect_test_collector_saved_stderr +var expect_test_collector_saved_stderr + +//Provides: expect_test_collector_before_test +//Requires: caml_global_data, caml_ml_channels +//Requires: expect_test_collector_saved_stderr, expect_test_collector_saved_stdout +function expect_test_collector_before_test (voutput, vstdout, vstderr){ + expect_test_collector_saved_stderr = caml_ml_channels[vstderr]; + expect_test_collector_saved_stdout = caml_ml_channels[vstdout]; + var output = caml_ml_channels[voutput]; + caml_ml_channels[vstdout] = output; + caml_ml_channels[vstderr] = output; + return 0; +} + +//Provides: expect_test_collector_after_test +//Requires: caml_global_data, caml_ml_channels +//Requires: expect_test_collector_saved_stderr, expect_test_collector_saved_stdout +function expect_test_collector_after_test (vstdout, vstderr){ + caml_ml_channels[vstdout] = expect_test_collector_saved_stdout; + caml_ml_channels[vstderr] = expect_test_collector_saved_stderr; + return 0; +} + +//Provides:caml_out_channel_pos_fd +//Requires: caml_global_data, caml_ml_channels +function caml_out_channel_pos_fd(chan){ + var info = caml_ml_channels[chan]; + return info.offset +} diff --git a/common/dune b/common/dune new file mode 100644 index 0000000..95993fe --- /dev/null +++ b/common/dune @@ -0,0 +1,4 @@ +(library (name expect_test_common) (public_name ppx_expect.common) + (synopsis "Shared parts for ppx_expect") (libraries base) + (preprocess no_preprocessing) + (lint (pps ppx_base ppx_base_lint -apply=js_style,base_lint,type_conv)))
\ No newline at end of file diff --git a/common/expect_test_common.ml b/common/expect_test_common.ml new file mode 100644 index 0000000..8ac4d62 --- /dev/null +++ b/common/expect_test_common.ml @@ -0,0 +1,7 @@ +module Std = struct + module File = File + module Expectation = Expectation +end +[@@deprecated "[since 2020-03] use [Expect_test_common] instead"] + +include Std [@@alert "-deprecated"] diff --git a/common/expectation.ml b/common/expectation.ml new file mode 100644 index 0000000..c20b156 --- /dev/null +++ b/common/expectation.ml @@ -0,0 +1,175 @@ +open! Base +open Import +open Ppx_compare_lib.Builtin +open Sexplib0.Sexp_conv + +module Body = struct + type 'a t = + | Exact of string + | Output + | Pretty of 'a + | Unreachable + [@@deriving_inline sexp_of, compare, equal] + + let _ = fun (_ : 'a t) -> () + + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__006_) : ((a__006_ -> Sexplib0.Sexp.t) -> a__006_ t -> Sexplib0.Sexp.t) -> + fun _of_a__001_ -> function + | Exact arg0__002_ -> + let res0__003_ = sexp_of_string arg0__002_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Exact"; res0__003_ ] + | Output -> Sexplib0.Sexp.Atom "Output" + | Pretty arg0__004_ -> + let res0__005_ = _of_a__001_ arg0__004_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Pretty"; res0__005_ ] + | Unreachable -> Sexplib0.Sexp.Atom "Unreachable" + ;; + + let _ = sexp_of_t + + let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__007_ b__008_ -> + if Stdlib.( == ) a__007_ b__008_ + then 0 + else ( + match a__007_, b__008_ with + | Exact _a__009_, Exact _b__010_ -> compare_string _a__009_ _b__010_ + | Exact _, _ -> -1 + | _, Exact _ -> 1 + | Output, Output -> 0 + | Output, _ -> -1 + | _, Output -> 1 + | Pretty _a__011_, Pretty _b__012_ -> _cmp__a _a__011_ _b__012_ + | Pretty _, _ -> -1 + | _, Pretty _ -> 1 + | Unreachable, Unreachable -> 0) + ;; + + let _ = compare + + let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = + fun _cmp__a a__013_ b__014_ -> + if Stdlib.( == ) a__013_ b__014_ + then true + else ( + match a__013_, b__014_ with + | Exact _a__015_, Exact _b__016_ -> equal_string _a__015_ _b__016_ + | Exact _, _ -> false + | _, Exact _ -> false + | Output, Output -> true + | Output, _ -> false + | _, Output -> false + | Pretty _a__017_, Pretty _b__018_ -> _cmp__a _a__017_ _b__018_ + | Pretty _, _ -> false + | _, Pretty _ -> false + | Unreachable, Unreachable -> true) + ;; + + let _ = equal + + [@@@end] + + let map_pretty t ~f = + match t with + | (Exact _ | Output | Unreachable) as t -> t + | Pretty x -> Pretty (f x) + ;; +end + +type 'a t = + { tag : string option + ; body : 'a Body.t + ; extid_location : File.Location.t + ; body_location : File.Location.t + } +[@@deriving_inline sexp_of, compare, equal] + +let _ = fun (_ : 'a t) -> () + +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun _of_a__019_ + { tag = tag__021_ + ; body = body__023_ + ; extid_location = extid_location__025_ + ; body_location = body_location__027_ + } -> + let bnds__020_ = ([] : _ Stdlib.List.t) in + let bnds__020_ = + let arg__028_ = File.Location.sexp_of_t body_location__027_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "body_location"; arg__028_ ] :: bnds__020_ + : _ Stdlib.List.t) + in + let bnds__020_ = + let arg__026_ = File.Location.sexp_of_t extid_location__025_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "extid_location"; arg__026_ ] :: bnds__020_ + : _ Stdlib.List.t) + in + let bnds__020_ = + let arg__024_ = Body.sexp_of_t _of_a__019_ body__023_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "body"; arg__024_ ] :: bnds__020_ + : _ Stdlib.List.t) + in + let bnds__020_ = + let arg__022_ = sexp_of_option sexp_of_string tag__021_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "tag"; arg__022_ ] :: bnds__020_ + : _ Stdlib.List.t) + in + Sexplib0.Sexp.List bnds__020_ +;; + +let _ = sexp_of_t + +let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__029_ b__030_ -> + if Stdlib.( == ) a__029_ b__030_ + then 0 + else ( + match compare_option compare_string a__029_.tag b__030_.tag with + | 0 -> + (match Body.compare _cmp__a a__029_.body b__030_.body with + | 0 -> + (match File.Location.compare a__029_.extid_location b__030_.extid_location with + | 0 -> File.Location.compare a__029_.body_location b__030_.body_location + | n -> n) + | n -> n) + | n -> n) +;; + +let _ = compare + +let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = + fun _cmp__a a__035_ b__036_ -> + if Stdlib.( == ) a__035_ b__036_ + then true + else + Stdlib.( && ) + (equal_option equal_string a__035_.tag b__036_.tag) + (Stdlib.( && ) + (Body.equal _cmp__a a__035_.body b__036_.body) + (Stdlib.( && ) + (File.Location.equal a__035_.extid_location b__036_.extid_location) + (File.Location.equal a__035_.body_location b__036_.body_location))) +;; + +let _ = equal + +[@@@end] + +module Raw = struct + type nonrec t = string t [@@deriving_inline sexp_of, compare] + + let _ = fun (_ : t) -> () + let sexp_of_t = (fun x__041_ -> sexp_of_t sexp_of_string x__041_ : t -> Sexplib0.Sexp.t) + let _ = sexp_of_t + + let compare = + (fun a__042_ b__043_ -> compare compare_string a__042_ b__043_ : t -> t -> int) + ;; + + let _ = compare + + [@@@end] +end + +let map_pretty t ~f = { t with body = Body.map_pretty t.body ~f } diff --git a/common/expectation.mli b/common/expectation.mli new file mode 100644 index 0000000..2bfc740 --- /dev/null +++ b/common/expectation.mli @@ -0,0 +1,66 @@ +open! Base +open Base.Exported_for_specific_uses (* for [Ppx_compare_lib] *) + +module Body : sig + type 'a t = + | Exact of string + | Output + | Pretty of 'a + | Unreachable + [@@deriving_inline sexp_of, compare, equal] + + include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val map_pretty : 'a t -> f:('a -> 'b) -> 'b t +end + +type 'a t = + { tag : string option (** Tag of the string payload *) + ; body : 'a Body.t + ; extid_location : File.Location.t + (** Location of the extension id ("expect" or + "expect_exact") *) + ; body_location : File.Location.t + (** Location of the string payload of the extension + point *) + } +[@@deriving_inline sexp_of, compare, equal] + +include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t +end +[@@ocaml.doc "@inline"] + +[@@@end] + +module Raw : sig + type nonrec t = string t [@@deriving_inline sexp_of, compare] + + include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] +end + +val map_pretty : 'a t -> f:('a -> 'b) -> 'b t diff --git a/common/file.ml b/common/file.ml new file mode 100644 index 0000000..18a4dc7 --- /dev/null +++ b/common/file.ml @@ -0,0 +1,230 @@ +open! Base +open Import + +module Name : sig + type t [@@deriving_inline sexp, compare] + + include sig + [@@@ocaml.warning "-32"] + + include Sexplib0.Sexpable.S with type t := t + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val relative_to : dir:string -> t -> string + + include Identifiable.S with type t := t +end = struct + include String + + let relative_to ~dir t = + if not (Stdlib.Filename.is_relative t) then t else Stdlib.Filename.concat dir t + ;; +end + +let initial_dir = + let dir_or_error = + match Stdlib.Sys.getcwd () with + | v -> `Ok v + | exception exn -> `Exn exn + in + fun () -> + match dir_or_error with + | `Ok v -> v + | `Exn exn -> raise exn +;; + +module Location = struct + module T = struct + type t = + { filename : Name.t + ; line_number : int + ; line_start : int + ; start_pos : int + ; end_pos : int + } + [@@deriving_inline sexp, compare] + + let _ = fun (_ : t) -> () + + let t_of_sexp = + (let error_source__002_ = "file.ml.Location.T.t" in + fun x__003_ -> + Sexplib0.Sexp_conv_record.record_of_sexp + ~caller:error_source__002_ + ~fields: + (Field + { name = "filename" + ; kind = Required + ; conv = Name.t_of_sexp + ; rest = + Field + { name = "line_number" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field + { name = "line_start" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field + { name = "start_pos" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field + { name = "end_pos" + ; kind = Required + ; conv = int_of_sexp + ; rest = Empty + } + } + } + } + }) + ~index_of_field:(function + | "filename" -> 0 + | "line_number" -> 1 + | "line_start" -> 2 + | "start_pos" -> 3 + | "end_pos" -> 4 + | _ -> -1) + ~allow_extra_fields:false + ~create: + (fun + (filename, (line_number, (line_start, (start_pos, (end_pos, ()))))) : t -> + { filename; line_number; line_start; start_pos; end_pos }) + x__003_ + : Sexplib0.Sexp.t -> t) + ;; + + let _ = t_of_sexp + + let sexp_of_t = + (fun { filename = filename__005_ + ; line_number = line_number__007_ + ; line_start = line_start__009_ + ; start_pos = start_pos__011_ + ; end_pos = end_pos__013_ + } -> + let bnds__004_ = ([] : _ Stdlib.List.t) in + let bnds__004_ = + let arg__014_ = sexp_of_int end_pos__013_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "end_pos"; arg__014_ ] :: bnds__004_ + : _ Stdlib.List.t) + in + let bnds__004_ = + let arg__012_ = sexp_of_int start_pos__011_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "start_pos"; arg__012_ ] :: bnds__004_ + : _ Stdlib.List.t) + in + let bnds__004_ = + let arg__010_ = sexp_of_int line_start__009_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "line_start"; arg__010_ ] + :: bnds__004_ + : _ Stdlib.List.t) + in + let bnds__004_ = + let arg__008_ = sexp_of_int line_number__007_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "line_number"; arg__008_ ] + :: bnds__004_ + : _ Stdlib.List.t) + in + let bnds__004_ = + let arg__006_ = Name.sexp_of_t filename__005_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "filename"; arg__006_ ] :: bnds__004_ + : _ Stdlib.List.t) + in + Sexplib0.Sexp.List bnds__004_ + : t -> Sexplib0.Sexp.t) + ;; + + let _ = sexp_of_t + + let compare = + (fun a__015_ b__016_ -> + if Stdlib.( == ) a__015_ b__016_ + then 0 + else ( + match Name.compare a__015_.filename b__016_.filename with + | 0 -> + (match compare_int a__015_.line_number b__016_.line_number with + | 0 -> + (match compare_int a__015_.line_start b__016_.line_start with + | 0 -> + (match compare_int a__015_.start_pos b__016_.start_pos with + | 0 -> compare_int a__015_.end_pos b__016_.end_pos + | n -> n) + | n -> n) + | n -> n) + | n -> n) + : t -> t -> int) + ;; + + let _ = compare + + [@@@end] + end + + include T + include Comparable.Make (T) + + let beginning_of_file filename = + { filename; line_number = 1; line_start = 0; start_pos = 0; end_pos = 0 } + ;; + + let of_source_code_position (pos : Source_code_position.t) = + { filename = Name.of_string (Stdlib.Filename.basename pos.pos_fname) + ; line_number = pos.pos_lnum + ; line_start = pos.pos_bol + ; start_pos = pos.pos_cnum + ; end_pos = pos.pos_cnum + } + ;; +end + +module Digest : sig + type t [@@deriving_inline sexp_of, compare] + + include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val to_string : t -> string + val of_string : string -> t +end = struct + type t = string [@@deriving_inline sexp_of, compare] + + let _ = fun (_ : t) -> () + let sexp_of_t = (sexp_of_string : t -> Sexplib0.Sexp.t) + let _ = sexp_of_t + let compare = (compare_string : t -> t -> int) + let _ = compare + + [@@@end] + + let to_string t = t + + let of_string s = + let expected_length = 32 in + if String.length s <> expected_length + then invalid_arg "Expect_test_collector.File.Digest.of_string, unexpected length"; + for i = 0 to expected_length - 1 do + match s.[i] with + | '0' .. '9' | 'a' .. 'f' -> () + | _ -> invalid_arg "Expect_test_collector.File.Digest.of_string" + done; + s + ;; +end diff --git a/common/file.mli b/common/file.mli new file mode 100644 index 0000000..2eb3a96 --- /dev/null +++ b/common/file.mli @@ -0,0 +1,68 @@ +open! Base +open Base.Exported_for_specific_uses (* for [Ppx_compare_lib] *) + +module Name : sig + (** Strongly-typed filename *) + type t [@@deriving_inline sexp, compare] + + include sig + [@@@ocaml.warning "-32"] + + include Sexplib0.Sexpable.S with type t := t + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val relative_to : dir:string -> t -> string + + include Identifiable.S with type t := t +end + +val initial_dir : unit -> string + +module Location : sig + (** Location within a file *) + type t = + { filename : Name.t + ; line_number : int + ; line_start : int + ; start_pos : int + ; end_pos : int + } + [@@deriving_inline sexp, compare] + + include sig + [@@@ocaml.warning "-32"] + + include Sexplib0.Sexpable.S with type t := t + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val beginning_of_file : Name.t -> t + val of_source_code_position : Source_code_position.t -> t + + include Comparable.S with type t := t +end + +module Digest : sig + type t [@@deriving_inline sexp_of, compare] + + include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S with type t := t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val of_string : string -> t + val to_string : t -> string +end diff --git a/common/import.ml b/common/import.ml new file mode 100644 index 0000000..1640542 --- /dev/null +++ b/common/import.ml @@ -0,0 +1 @@ +module Ppx_compare_lib = Base.Exported_for_specific_uses.Ppx_compare_lib diff --git a/config/dune b/config/dune new file mode 100644 index 0000000..ca49c3b --- /dev/null +++ b/config/dune @@ -0,0 +1,3 @@ +(library (name expect_test_config) (public_name ppx_expect.config) + (synopsis "Default runtime configuration for ppx_expect") + (libraries expect_test_config_types) (preprocess no_preprocessing))
\ No newline at end of file diff --git a/config/expect_test_config.ml b/config/expect_test_config.ml new file mode 100644 index 0000000..c0787b6 --- /dev/null +++ b/config/expect_test_config.ml @@ -0,0 +1,9 @@ +module IO = struct + type 'a t = 'a + + let return x = x +end + +let sanitize s = s +let run f = f () +let upon_unreleasable_issue = `CR diff --git a/config/expect_test_config.mli b/config/expect_test_config.mli new file mode 100644 index 0000000..9a2386d --- /dev/null +++ b/config/expect_test_config.mli @@ -0,0 +1 @@ +include Expect_test_config_types.S with type 'a IO.t = 'a diff --git a/config/types/dune b/config/types/dune new file mode 100644 index 0000000..afaca10 --- /dev/null +++ b/config/types/dune @@ -0,0 +1,4 @@ +(library (name expect_test_config_types) + (public_name ppx_expect.config_types) + (synopsis "Runtime configuration options for ppx_expect") (libraries) + (preprocess no_preprocessing))
\ No newline at end of file diff --git a/config/types/expect_test_config_types.ml b/config/types/expect_test_config_types.ml new file mode 100644 index 0000000..4a7bc22 --- /dev/null +++ b/config/types/expect_test_config_types.ml @@ -0,0 +1,26 @@ +module type S = Expect_test_config_types_intf.S + +module type Expect_test_config_types = + Expect_test_config_types_intf.Expect_test_config_types + +module Upon_unreleasable_issue = struct + include Expect_test_config_types_intf.Upon_unreleasable_issue + + let equal t1 t2 = t1 = t2 + + let comment_prefix = function + | `CR -> "CR " + | `Warning_for_collector_testing -> "" + ;; + + let message_when_expectation_contains_backtrace t = + Printf.sprintf + {| +(* %sexpect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + +|} + (comment_prefix t) + ;; +end diff --git a/config/types/expect_test_config_types.mli b/config/types/expect_test_config_types.mli new file mode 100644 index 0000000..f132581 --- /dev/null +++ b/config/types/expect_test_config_types.mli @@ -0,0 +1 @@ +include Expect_test_config_types_intf.Expect_test_config_types diff --git a/config/types/expect_test_config_types_intf.ml b/config/types/expect_test_config_types_intf.ml new file mode 100644 index 0000000..1f41252 --- /dev/null +++ b/config/types/expect_test_config_types_intf.ml @@ -0,0 +1,54 @@ +module Upon_unreleasable_issue = struct + type t = + [ `CR (** Leaves a CR, so that features cannot be released. *) + | `Warning_for_collector_testing (** Only for ppx_expect testing; do not use. *) + ] +end + +module type S = sig + module IO : sig + type 'a t + + val return : 'a -> 'a t + end + + (** Run an IO operation until completion *) + val run : (unit -> unit IO.t) -> unit + + (** [sanitize] can be used to map all output strings, e.g. for cleansing. *) + val sanitize : string -> string + + + (** [upon_unreleasable_issue] specifies how to deal with output that should not be + released even if it is accepted (e.g. backtraces). The default is [`CR]. *) + val upon_unreleasable_issue : Upon_unreleasable_issue.t +end + +(** Configuration for running expect tests *) +module type Expect_test_config_types = sig + (** To configure expect_test, add the following at the top of your .ml file, or in some + import.ml: + + {[ + module Expect_test_config = struct + include Expect_test_config + let pre_redirect_hook () = ... + end + ]} + + Note that since all expect test are also inline tests, the inline test configuration + also applies to all expect test. + *) + + module Upon_unreleasable_issue : sig + include module type of Upon_unreleasable_issue + + val equal : t -> t -> bool + val comment_prefix : t -> string + + (** Message to print when an expectation contains a backtrace *) + val message_when_expectation_contains_backtrace : t -> string + end + + module type S = S +end diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..eb10bcb --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 1.10)
\ No newline at end of file diff --git a/evaluator/dune b/evaluator/dune new file mode 100644 index 0000000..6976b12 --- /dev/null +++ b/evaluator/dune @@ -0,0 +1,4 @@ +(library (name ppx_expect_evaluator) (public_name ppx_expect.evaluator) + (libraries base stdio expect_test_common expect_test_collector + expect_test_matcher make_corrected_file ppxlib.print_diff) + (preprocess no_preprocessing) (library_flags -linkall))
\ No newline at end of file diff --git a/evaluator/ppx_expect_evaluator.ml b/evaluator/ppx_expect_evaluator.ml new file mode 100644 index 0000000..8c682c0 --- /dev/null +++ b/evaluator/ppx_expect_evaluator.ml @@ -0,0 +1,256 @@ +open Base +open Stdio +open Expect_test_common +open Expect_test_matcher +module Test_result = Ppx_inline_test_lib.Test_result +module Collector_test_outcome = Expect_test_collector.Test_outcome + +type group = + { filename : File.Name.t + ; file_contents : string + ; tests : Matcher.Test_outcome.t Map.M(File.Location).t + } + +let convert_collector_test ~allow_output_patterns (test : Collector_test_outcome.t) + : File.Location.t * Matcher.Test_outcome.t + = + let saved_output = + Map.of_alist_multi (module File.Location) test.saved_output + |> Map.map ~f:Matcher.Saved_output.of_nonempty_list_exn + in + let expectations = + List.map test.expectations ~f:(fun (expect : Expectation.Raw.t) -> + ( expect.extid_location + , Expectation.map_pretty expect ~f:(Lexer.parse_pretty ~allow_output_patterns) )) + |> Map.of_alist_exn (module File.Location) + in + let uncaught_exn = + match test.uncaught_exn with + | None -> None + | Some (exn, bt) -> + let exn = + try Exn.to_string exn with + | exn -> + let name = + Stdlib.Obj.Extension_constructor.of_val exn + |> Stdlib.Obj.Extension_constructor.name + in + Printf.sprintf "(\"%s(Cannot print more details, Exn.to_string failed)\")" name + in + Some + (match Stdlib.Printexc.raw_backtrace_to_string bt with + | "" -> exn + | bt -> + Expect_test_config_types.Upon_unreleasable_issue + .message_when_expectation_contains_backtrace + test.upon_unreleasable_issue + ^ exn + ^ "\n" + ^ bt) + in + let uncaught_exn, trailing_output = + match uncaught_exn, test.trailing_output with + | None, _ | _, "" -> uncaught_exn, test.trailing_output + | Some uncaught_exn, trailing_output -> + ( Some + (String.concat + ~sep:"\n" + [ uncaught_exn; "Trailing output"; "---------------"; trailing_output ]) + , "" ) + in + let uncaught_exn_expectation = + Option.map test.uncaught_exn_expectation ~f:(fun expect -> + Expectation.map_pretty expect ~f:(Lexer.parse_pretty ~allow_output_patterns)) + in + ( test.location + , { expectations + ; saved_output + ; trailing_output = Matcher.Saved_output.of_nonempty_list_exn [ trailing_output ] + ; uncaught_exn = + Option.map uncaught_exn ~f:(fun s -> + Matcher.Saved_output.of_nonempty_list_exn [ s ]) + ; uncaught_exn_expectation + ; upon_unreleasable_issue = test.upon_unreleasable_issue + } ) +;; + +let dir_seps = '/' :: (if Sys.win32 then [ '\\'; ':' ] else []) + +let resolve_filename filename = + let relative_to = + match Ppx_inline_test_lib.source_tree_root with + | None -> File.initial_dir () + | Some root -> + if Stdlib.Filename.is_relative root + then ( + let initial_dir = File.initial_dir () in + (* Simplification for the common case where [root] is of the form [(../)*..] *) + let l = String.split_on_chars root ~on:dir_seps in + if List.for_all l ~f:(String.equal Stdlib.Filename.parent_dir_name) + then + List.fold_left l ~init:initial_dir ~f:(fun dir _ -> Stdlib.Filename.dirname dir) + else Stdlib.Filename.concat initial_dir root) + else root + in + File.Name.relative_to ~dir:relative_to filename +;; + +let create_group ~allow_output_patterns (filename, tests) = + let module D = File.Digest in + let expected_digest = + match + List.map tests ~f:(fun (t : Collector_test_outcome.t) -> t.file_digest) + |> List.dedup_and_sort ~compare:D.compare + with + | [ digest ] -> digest + | [] -> assert false + | digests -> + Printf.ksprintf + failwith + "Expect tests make inconsistent assumption about file \"%s\" %s" + (File.Name.to_string filename) + (Sexp.to_string_hum (List.sexp_of_t D.sexp_of_t digests)) + in + let file_contents = In_channel.read_all (resolve_filename filename) in + let current_digest = + Stdlib.Digest.string file_contents |> Stdlib.Digest.to_hex |> D.of_string + in + if D.compare expected_digest current_digest <> 0 + then + Printf.ksprintf + failwith + "File \"%s\" changed, you need rebuild inline_tests_runner to be able to run \ + expect tests (expected digest: %s, current digest: %s)" + (File.Name.to_string filename) + (D.to_string expected_digest) + (D.to_string current_digest); + let tests = + List.map tests ~f:(convert_collector_test ~allow_output_patterns) + |> Map.of_alist_reduce (module File.Location) ~f:Matcher.Test_outcome.merge_exn + in + { filename; file_contents; tests } +;; + +let convert_collector_tests ~allow_output_patterns tests : group list = + List.map tests ~f:(fun (test : Collector_test_outcome.t) -> + test.location.filename, test) + |> Map.of_alist_multi (module File.Name) + |> Map.to_alist + |> List.map ~f:(create_group ~allow_output_patterns) +;; + +let process_group + ~use_color + ~in_place + ~diff_command + ~diff_path_prefix + ~allow_output_patterns + { filename; file_contents; tests } + : Test_result.t + = + let bad_outcomes = + Map.fold tests ~init:[] ~f:(fun ~key:location ~data:test acc -> + match + Matcher.evaluate_test ~file_contents ~location test ~allow_output_patterns + with + | Match -> acc + | Correction c -> c :: acc) + |> List.rev + in + let filename = resolve_filename filename in + let dot_corrected = filename ^ ".corrected" in + let remove file = if Stdlib.Sys.file_exists file then Stdlib.Sys.remove file in + match bad_outcomes with + | [] -> + remove dot_corrected; + Success + | _ :: _ -> + let next_contents = + Matcher.get_contents_for_corrected_file + ~file_contents + ~mode:Inline_expect_test + bad_outcomes + in + (match in_place with + | true -> + Out_channel.write_all filename ~data:next_contents; + remove dot_corrected; + Success + | false -> + (match diff_command with + | Some "-" (* Just write the .corrected file - do not output a diff. *) -> + Out_channel.write_all dot_corrected ~data:next_contents; + Success + | None | Some _ -> + (* By invoking [Make_corrected_file.f] with a fresh temporary file, we avoid the + following possible race between inline_test_runners A and B: + 1. A runs test T1 and generates next contents C1. + 2. B runs test T2 and generates next contents C2. + 3. A writes C1 to the .corrected file. + 4. B writes C2 to the .corrected file. + 5. A diffs the .corrected file against the original file and reports the + result. It thinks it is reporting the diff produced by T1, but is in fact + reporting the diff produced by T2. The key aspect of using temporary files is + that even if in the above scenario the final contents of the .corrected file + are C2, the diff reported by A comes from its tmp file and will still be the + diff produced by T1. *) + let tmp_corrected = + Stdlib.Filename.temp_file + (Stdlib.Filename.basename filename) + ".corrected.tmp" + ~temp_dir:(Stdlib.Filename.dirname filename) + in + let (Ok () | Error (_ : Error.t)) = + Make_corrected_file.f + ~corrected_path:tmp_corrected + ~use_color + ?diff_command + ?diff_path_prefix + ~next_contents + ~path:filename + () + in + Stdlib.Sys.rename tmp_corrected dot_corrected; + Failure)) +;; + +let evaluate_tests + ~use_color + ~in_place + ~diff_command + ~diff_path_prefix + ~allow_output_patterns + = + convert_collector_tests (Expect_test_collector.tests_run ()) ~allow_output_patterns + |> List.map ~f:(fun group -> + match + process_group + ~use_color + ~in_place + ~diff_command + ~diff_path_prefix + ~allow_output_patterns + group + with + | exception exn -> + let bt = Stdlib.Printexc.get_raw_backtrace () in + raise_s + (Sexp.message + "Expect test evaluator bug" + [ "exn", sexp_of_exn exn + ; "backtrace", Atom (Stdlib.Printexc.raw_backtrace_to_string bt) + ; "filename", File.Name.sexp_of_t group.filename + ]) + | res -> res) + |> Test_result.combine_all +;; + +let () = + Ppx_inline_test_lib.add_evaluator ~f:(fun () -> + evaluate_tests + ~use_color:Ppx_inline_test_lib.use_color + ~in_place:Ppx_inline_test_lib.in_place + ~diff_command:Ppx_inline_test_lib.diff_command + ~diff_path_prefix:Ppx_inline_test_lib.diff_path_prefix + ~allow_output_patterns:false) +;; diff --git a/evaluator/ppx_expect_evaluator.mli b/evaluator/ppx_expect_evaluator.mli new file mode 100644 index 0000000..e790aeb --- /dev/null +++ b/evaluator/ppx_expect_evaluator.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/example/chdir.ml b/example/chdir.ml new file mode 100644 index 0000000..aa7298a --- /dev/null +++ b/example/chdir.ml @@ -0,0 +1,9 @@ +(* The test framework should be resilient to user changing the current directory. *) + +let%expect_test _ = + print_string "hello world\n"; + Unix.chdir ".."; + [%expect {| + hello world +|}] +;; diff --git a/example/chdir.mli b/example/chdir.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/chdir.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/control_chars.ml b/example/control_chars.ml Binary files differnew file mode 100644 index 0000000..90c9f14 --- /dev/null +++ b/example/control_chars.ml diff --git a/example/control_chars.mli b/example/control_chars.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/control_chars.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/dune b/example/dune new file mode 100644 index 0000000..dae1980 --- /dev/null +++ b/example/dune @@ -0,0 +1,9 @@ +(library (name expect_test_examples) (libraries core async) + (preprocess (pps ppx_jane))) + +(rule (targets tabs.ml) (deps (:first_dep tabs.ml.in) jbuild) + (action + (bash + "cp %{first_dep} %{targets}; %{bin:apply-style} -directory-config jbuild -in-place %{targets}"))) + +(alias (name DEFAULT) (deps tests.ml.pp))
\ No newline at end of file diff --git a/example/flexible_whitespace.ml b/example/flexible_whitespace.ml new file mode 100644 index 0000000..55d695a --- /dev/null +++ b/example/flexible_whitespace.ml @@ -0,0 +1,6 @@ +let%expect_test _ = + print_string " Be more"; + [%expect {| Be more |}]; + print_string "\nflexible\n"; + [%expect {| flexible |}] +;; diff --git a/example/flexible_whitespace.mli b/example/flexible_whitespace.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/flexible_whitespace.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/function.ml b/example/function.ml new file mode 100644 index 0000000..7c2d9d9 --- /dev/null +++ b/example/function.ml @@ -0,0 +1,17 @@ +let%expect_test _ = + let f output = + print_string output; + [%expect {| hello world |}] + in + f "hello world"; + f "hello world" +;; + +let%expect_test _ = + let f () = + print_string ""; + [%expect {| |}] + in + f (); + f () +;; diff --git a/example/function.mli b/example/function.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/function.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/functor.ml b/example/functor.ml new file mode 100644 index 0000000..fbb63b5 --- /dev/null +++ b/example/functor.ml @@ -0,0 +1,9 @@ +module M () = struct + let%expect_test _ = + print_string "hello world"; + [%expect {| hello world |}] + ;; +end + +module A = M () +module B = M () diff --git a/example/hello_async.ml b/example/hello_async.ml new file mode 100644 index 0000000..2a5d525 --- /dev/null +++ b/example/hello_async.ml @@ -0,0 +1,8 @@ +open Core +open Async + +let%expect_test _ = + List.iter [ "hello, "; "world"; "!" ] ~f:(fun s -> print_string s); + [%expect {| hello, world! |}]; + return () +;; diff --git a/example/hello_async.mli b/example/hello_async.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/hello_async.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/nine.ml b/example/nine.ml new file mode 100644 index 0000000..9ee2de2 --- /dev/null +++ b/example/nine.ml @@ -0,0 +1,105 @@ +(* + Demonstate use of [%expect] + to match a single line of text with 0|1|2 leading & trailing NLs. + + Starting with.. + + {[ + let%expect_test _ = + let module M = struct + let () = print_string "hello"; [%expect{||}] + let () = print_string "hello\n"; [%expect{||}] + let () = print_string "hello\n\n"; [%expect{||}] + let () = print_string "\nhello"; [%expect{||}] + let () = print_string "\nhello\n"; [%expect{||}] + let () = print_string "\nhello\n\n"; [%expect{||}] + let () = print_string "\n\nhello"; [%expect{||}] + let () = print_string "\n\nhello\n"; [%expect{||}] + let () = print_string "\n\nhello\n\n"; [%expect{||}] + end in () + ]} + + Generate with [cp nine.ml.corrected nine.ml] the following [%expect]... *) + +let%expect_test _ = + let module _ = struct + let () = + print_string "hello"; + [%expect {| hello |}] + ;; + + let () = + print_string "hello\n"; + [%expect + {| + hello + |}] + ;; + + let () = + print_string "hello\n\n"; + [%expect + {| + hello + + |}] + ;; + + let () = + print_string "\nhello"; + [%expect {| + + hello|}] + ;; + + let () = + print_string "\nhello\n"; + [%expect + {| + + hello + |}] + ;; + + let () = + print_string "\nhello\n\n"; + [%expect + {| + + hello + + |}] + ;; + + let () = + print_string "\n\nhello"; + [%expect {| + + + hello|}] + ;; + + let () = + print_string "\n\nhello\n"; + [%expect + {| + + + hello + |}] + ;; + + let () = + print_string "\n\nhello\n\n"; + [%expect + {| + + + hello + + |}] + ;; + end + in + () +;; diff --git a/example/nine.mli b/example/nine.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/nine.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/reordered.ml b/example/reordered.ml new file mode 100644 index 0000000..2573b3d --- /dev/null +++ b/example/reordered.ml @@ -0,0 +1,9 @@ +let%expect_test _ = + let f () = + print_string "bar"; + [%expect {| bar |}] + in + print_string "foo"; + [%expect {| foo |}]; + f () +;; diff --git a/example/reordered.mli b/example/reordered.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/reordered.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/space_nine.ml b/example/space_nine.ml new file mode 100644 index 0000000..0af4898 --- /dev/null +++ b/example/space_nine.ml @@ -0,0 +1,43 @@ +(* + Demonstate use of [%expect] + to match a single line of text with 0|1|2 leading & trailing NLs. + The text begins with a single space. + + Starting with.. + + {[ + let%expect_test _ = + print_string " hello"; [%expect{||}]; + print_string " hello\n"; [%expect{||}]; + print_string " hello\n\n"; [%expect{||}]; + print_string "\n hello"; [%expect{||}]; + print_string "\n hello\n"; [%expect{||}]; + print_string "\n hello\n\n"; [%expect{||}]; + print_string "\n\n hello"; [%expect{||}]; + print_string "\n\n hello\n"; [%expect{||}]; + print_string "\n\n hello\n\n"; [%expect{||}]; + ;; + ]} + + Generate with [cp space_nine.ml.corrected space_nine.ml] the following [%expect]... *) + +let%expect_test _ = + print_string " hello"; + [%expect_exact " hello"]; + print_string " hello\n"; + [%expect_exact " hello\n"]; + print_string " hello\n\n"; + [%expect_exact " hello\n\n"]; + print_string "\n hello"; + [%expect_exact "\n hello"]; + print_string "\n hello\n"; + [%expect_exact "\n hello\n"]; + print_string "\n hello\n\n"; + [%expect_exact "\n hello\n\n"]; + print_string "\n\n hello"; + [%expect_exact "\n\n hello"]; + print_string "\n\n hello\n"; + [%expect_exact "\n\n hello\n"]; + print_string "\n\n hello\n\n"; + [%expect_exact "\n\n hello\n\n"] +;; diff --git a/example/space_nine.mli b/example/space_nine.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/space_nine.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/tabs.ml.in b/example/tabs.ml.in new file mode 100644 index 0000000..251d065 --- /dev/null +++ b/example/tabs.ml.in @@ -0,0 +1,11 @@ + +(* Hydra doesn't like .ml files containing tab chars. So such examples need to go here *) + +let%expect_test _ = + print_string "I have 8 spaces before me"; + [%expect {| + I have 8 spaces before me|}]; + + print_string "I have a tab char before me"; + [%expect {| + I have a tab char before me|}] diff --git a/example/tabs.mli b/example/tabs.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/tabs.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/tests.ml b/example/tests.ml new file mode 100644 index 0000000..5b21e11 --- /dev/null +++ b/example/tests.ml @@ -0,0 +1,31 @@ +open Core + +(* We may use other syntax extensions when writing expect tests. *) +type t = int list [@@deriving sexp_of] + +let pr s = Printf.printf "%s\n" s + + +let%expect_test "foo" = + pr "line1"; + pr (Sexp.to_string (sexp_of_t [ 1; 2; 3 ])); + [%expect {| + line1 + (1 2 3) + |}] +;; + +let%expect_test _ = + print_string "hello, world!"; + [%expect "hello, world!"] +;; + +let%expect_test _ = + print_string "hello, world!"; + [%expect_exact {|hello, world!|}] +;; + +let%expect_test _ = + print_string "I need |}weird escaping"; + [%expect {xxx| I need |}weird escaping |xxx}] +;; diff --git a/example/tests.mli b/example/tests.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/tests.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/three.ml b/example/three.ml new file mode 100644 index 0000000..1049b17 --- /dev/null +++ b/example/three.ml @@ -0,0 +1,33 @@ +(* The idea behind this sequence of examples is as follows. Starting with the same [text], + We explore various [%expect] declarations which match it. *) + +let%expect_test _ = + let text_no_final_nl () = print_string "one\ntwo\nthree" in + text_no_final_nl (); + [%expect {| + one + two + three|}]; + let text () = print_string "one\ntwo\nthree\n" in + (* Base example *) + text (); + [%expect {| + one + two + three +|}]; + (* ok to omit space between "expect" and "{" *) + text (); + [%expect {| + one + two + three +|}]; + (* indentation allowed *) + text (); + [%expect {| + one + two + three +|}] +;; diff --git a/example/three.mli b/example/three.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/three.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/example/xnine.ml b/example/xnine.ml new file mode 100644 index 0000000..3da9032 --- /dev/null +++ b/example/xnine.ml @@ -0,0 +1,42 @@ +(* + Demonstate use of [%expect_exact] + to match a single line of text with 0|1|2 leading & trailing NLs. + + Starting with.. + + {[ + let%expect_test _ = + print_string "hello"; [%expect_exact ""]; + print_string "hello\n"; [%expect_exact ""]; + print_string "hello\n\n"; [%expect_exact ""]; + print_string "\nhello"; [%expect_exact ""]; + print_string "\nhello\n"; [%expect_exact ""]; + print_string "\nhello\n\n"; [%expect_exact ""]; + print_string "\n\nhello"; [%expect_exact ""]; + print_string "\n\nhello\n"; [%expect_exact ""]; + print_string "\n\nhello\n\n"; [%expect_exact ""]; + ;; + ]} + + Generate with [cp xnine.ml.corrected xnine.ml] the following [%expect_exact]... *) + +let%expect_test _ = + print_string "hello"; + [%expect_exact {|hello|}]; + print_string "hello\n"; + [%expect_exact "hello\n"]; + print_string "hello\n\n"; + [%expect_exact "hello\n\n"]; + print_string "\nhello"; + [%expect_exact "\nhello"]; + print_string "\nhello\n"; + [%expect_exact "\nhello\n"]; + print_string "\nhello\n\n"; + [%expect_exact "\nhello\n\n"]; + print_string "\n\nhello"; + [%expect_exact "\n\nhello"]; + print_string "\n\nhello\n"; + [%expect_exact "\n\nhello\n"]; + print_string "\n\nhello\n\n"; + [%expect_exact "\n\nhello\n\n"] +;; diff --git a/example/xnine.mli b/example/xnine.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/example/xnine.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/expect_payload/dune b/expect_payload/dune new file mode 100644 index 0000000..5f3dc0d --- /dev/null +++ b/expect_payload/dune @@ -0,0 +1,2 @@ +(library (name ppx_expect_payload) (public_name ppx_expect.payload) + (libraries expect_test_common ppxlib) (preprocess no_preprocessing))
\ No newline at end of file diff --git a/expect_payload/ppx_expect_payload.ml b/expect_payload/ppx_expect_payload.ml new file mode 100644 index 0000000..60b3eae --- /dev/null +++ b/expect_payload/ppx_expect_payload.ml @@ -0,0 +1,92 @@ +open Expect_test_common +open Ppxlib + +let transl_loc (loc : Location.t) : File.Location.t = + { filename = File.Name.of_string loc.loc_start.pos_fname + ; line_start = loc.loc_start.pos_bol + ; line_number = loc.loc_start.pos_lnum + ; start_pos = loc.loc_start.pos_cnum + ; end_pos = loc.loc_end.pos_cnum + } +;; + +type data = Location.t * string * string option + +type kind = + | Normal + | Exact + | Unreachable + | Output + +let make ~kind payload ~(extension_id_loc : Location.t) = + let body_loc, body, tag = + match kind, payload with + | Unreachable, Some (loc, _, _) -> + Location.raise_errorf ~loc "expect.unreachable accepts no payload" () + | Unreachable, None -> + ( { extension_id_loc with loc_start = extension_id_loc.loc_end } + , Expectation.Body.Unreachable + , Some "" ) + | Normal, Some (loc, s, tag) -> loc, Pretty s, tag + | Exact, Some (loc, s, tag) -> loc, Exact s, tag + | Output, Some (loc, _, _) -> + Location.raise_errorf ~loc "expect.output accepts no payload" () + | Output, None -> + ( { extension_id_loc with loc_start = extension_id_loc.loc_end } + , Expectation.Body.Output + , None ) + | _, None -> + ( { extension_id_loc with loc_start = extension_id_loc.loc_end } + , Expectation.Body.Pretty "" + , Some "" ) + in + let res : Expectation.Raw.t = + { tag + ; body + ; extid_location = transl_loc extension_id_loc + ; body_location = transl_loc body_loc + } + in + (* Check that we are not in this case: + {[ + [%expect {|foo + bar + |}] + ]} + *) + match body with + | Exact _ | Output | Unreachable -> res + | Pretty s -> + let len = String.length s in + let get i = if i >= len then None else Some s.[i] in + let rec first_line i = + match get i with + | None -> () + | Some (' ' | '\t' | '\r') -> first_line (i + 1) + | Some '\n' -> () + | Some _ -> first_line_has_stuff (i + 1) + and first_line_has_stuff i = + match get i with + | None -> () + | Some '\n' -> rest_must_be_empty (i + 1) + | Some _ -> first_line_has_stuff (i + 1) + and rest_must_be_empty i = + match get i with + | None -> () + | Some (' ' | '\t' | '\r' | '\n') -> rest_must_be_empty (i + 1) + | Some _ -> + Location.raise_errorf + ~loc:body_loc + "Multi-line expectations must start with an empty line" + in + if kind = Normal then first_line 0; + res +;; + +let pattern () = + Ast_pattern.( + map + (single_expr_payload (pexp_loc __ (pexp_constant (pconst_string __ __ __)))) + ~f:(fun f loc s _ tag -> f (Some (loc, s, tag))) + ||| map (pstr nil) ~f:(fun f -> f None)) +;; diff --git a/expect_payload/ppx_expect_payload.mli b/expect_payload/ppx_expect_payload.mli new file mode 100644 index 0000000..fdb830b --- /dev/null +++ b/expect_payload/ppx_expect_payload.mli @@ -0,0 +1,16 @@ +open Ppxlib +open Expect_test_common + +(** Translate a compile time location to a runtime location *) +val transl_loc : Location.t -> File.Location.t + +type data = Location.t * string * string option (* string loc, string, tag *) + +type kind = + | Normal + | Exact + | Unreachable + | Output + +val make : kind:kind -> data option -> extension_id_loc:Location.t -> Expectation.Raw.t +val pattern : unit -> (Parsetree.payload, data option -> 'a, 'a) Ast_pattern.t diff --git a/make-corrected-file/dune b/make-corrected-file/dune new file mode 100644 index 0000000..72f406b --- /dev/null +++ b/make-corrected-file/dune @@ -0,0 +1,3 @@ +(library (name make_corrected_file) + (public_name ppx_expect.make_corrected_file) + (libraries base ppxlib.print_diff stdio) (preprocess no_preprocessing))
\ No newline at end of file diff --git a/make-corrected-file/import.ml b/make-corrected-file/import.ml new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/make-corrected-file/import.ml diff --git a/make-corrected-file/make_corrected_file.ml b/make-corrected-file/make_corrected_file.ml new file mode 100644 index 0000000..9d5238f --- /dev/null +++ b/make-corrected-file/make_corrected_file.ml @@ -0,0 +1,61 @@ +open! Base +open! Import + +let chop_if_exists ~ancestor ~from:path = + String.chop_prefix_if_exists path ~prefix:(ancestor ^ "/") +;; + +let f + ?(use_dot_patdiff = false) + ?corrected_path + ?(use_color = false) + ?diff_command + ?diff_path_prefix + ~next_contents + ~path + () + = + let prev_contents = Stdio.In_channel.with_file path ~f:Stdio.In_channel.input_all in + match String.( = ) prev_contents next_contents with + | true -> + (* It's possible for stale .corrected files to linger and ideally we would delete them + here, but this probably isn't worth fixing since it's mooted by dune, which puts + its build products in a separate directory. If we do add deletion at some point in + the future, we should make sure it doesn't cause problems for clients who call [f] + and then perform deletion on their own. *) + Ok () + | false -> + let default_corrected_path = path ^ ".corrected" in + let corrected_path = Option.value corrected_path ~default:default_corrected_path in + Stdio.Out_channel.write_all corrected_path ~data:next_contents; + let extra_patdiff_args = + let default_configs = + match use_dot_patdiff && Option.is_none (Sys.getenv "TESTING_FRAMEWORK") with + | true -> [] + | false -> [ "-default" ] + in + let cwd = Stdlib.Sys.getcwd () in + (* diff_path_prefix is useful to transform output paths to make it easier for the + consumer (e.g. editor) to locate the files with diffs. One particular example this + helps is the "test-this-file" rules generated by emacs/vscode in jenga/start/jbuild, + where the rule and the test are in different directories. *) + let prefix = + match diff_path_prefix with + | Some prefix -> String.rstrip ~drop:(Char.equal '/') prefix ^ "/" + | None -> "" + in + let alt_old = [ "-alt-old"; prefix ^ chop_if_exists ~ancestor:cwd ~from:path ] in + let alt_new = + [ "-alt-new"; prefix ^ chop_if_exists ~ancestor:cwd ~from:default_corrected_path ] + in + [ default_configs; alt_old; alt_new ] |> List.concat + in + Ppxlib_print_diff.print + ?diff_command + ~use_color + ~extra_patdiff_args + ~file1:path + ~file2:corrected_path + (); + Error (Error.of_string "Changes found.") +;; diff --git a/make-corrected-file/make_corrected_file.mli b/make-corrected-file/make_corrected_file.mli new file mode 100644 index 0000000..2b649ab --- /dev/null +++ b/make-corrected-file/make_corrected_file.mli @@ -0,0 +1,20 @@ +open! Base + +(** [f ~next_contents ~path ()] compares the contents of [path] against [next_contents]. + If the contents are unchanged, [f] returns [Ok ()]. If they are changed, it writes + [next_contents] to [corrected_path], emits a build error, and returns [Error _]. The + caller should exit nonzero (possibly by raising the returned error) to indicate to the + build that an error occurred. If it doesn't, the build system may not recognize that a + corrected file has been generated and needs to be moved out of a sandbox. + + The optional arguments support "expert" use cases. Most clients do not need them. *) +val f + : ?use_dot_patdiff:bool (** default: [false] *) + -> ?corrected_path:string (** default: [path ^ ".corrected"] *) + -> ?use_color:bool (** default: [false] *) + -> ?diff_command:string + -> ?diff_path_prefix:string + -> next_contents:string + -> path:string + -> unit + -> unit Or_error.t diff --git a/matcher/choose_tag.ml b/matcher/choose_tag.ml new file mode 100644 index 0000000..094fb1f --- /dev/null +++ b/matcher/choose_tag.ml @@ -0,0 +1,11 @@ +open Base + +let choose ~default body = + let terminators = Lexer.extract_quoted_string_terminators body in + let rec loop tag = + if List.mem terminators tag ~equal:String.equal then loop (tag ^ "x") else tag + in + if List.mem terminators default ~equal:String.equal + then loop (if String.is_empty default then "xxx" else default ^ "_xxx") + else default +;; diff --git a/matcher/choose_tag.mli b/matcher/choose_tag.mli new file mode 100644 index 0000000..1c1fda0 --- /dev/null +++ b/matcher/choose_tag.mli @@ -0,0 +1 @@ +val choose : default:string -> string -> string diff --git a/matcher/cst.ml b/matcher/cst.ml new file mode 100644 index 0000000..38aa491 --- /dev/null +++ b/matcher/cst.ml @@ -0,0 +1,659 @@ +open! Base +open! Import + +let for_all_string s ~f = + let b = ref true in + for i = 0 to String.length s - 1 do + b := !b && f s.[i] + done; + !b +;; + +let is_blank = function + | ' ' | '\t' -> true + | _ -> false +;; + +let is_space = function + | ' ' | '\t' | '\n' -> true + | _ -> false +;; + +let is_blanks s = for_all_string s ~f:is_blank + +let is_conflict_marker s = + String.equal s "=======" + || List.exists [ "<<<<<<< "; "||||||| "; ">>>>>>> " ] ~f:(fun prefix -> + String.is_prefix s ~prefix) +;; + +let is_spaces s = for_all_string s ~f:is_space +let no_nl s = for_all_string s ~f:(fun c -> Char.( <> ) c '\n') +let has_nl s = not (no_nl s) + +module Line = struct + type 'a not_blank = + { trailing_blanks : string + ; orig : string + ; data : 'a + } + [@@deriving_inline sexp_of, compare, equal] + + let _ = fun (_ : 'a not_blank) -> () + + let sexp_of_not_blank : 'a. ('a -> Sexplib0.Sexp.t) -> 'a not_blank -> Sexplib0.Sexp.t = + fun _of_a__001_ + { trailing_blanks = trailing_blanks__003_; orig = orig__005_; data = data__007_ } -> + let bnds__002_ = ([] : _ Stdlib.List.t) in + let bnds__002_ = + let arg__008_ = _of_a__001_ data__007_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "data"; arg__008_ ] :: bnds__002_ + : _ Stdlib.List.t) + in + let bnds__002_ = + let arg__006_ = sexp_of_string orig__005_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "orig"; arg__006_ ] :: bnds__002_ + : _ Stdlib.List.t) + in + let bnds__002_ = + let arg__004_ = sexp_of_string trailing_blanks__003_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "trailing_blanks"; arg__004_ ] + :: bnds__002_ + : _ Stdlib.List.t) + in + Sexplib0.Sexp.List bnds__002_ + ;; + + let _ = sexp_of_not_blank + + let compare_not_blank : 'a. ('a -> 'a -> int) -> 'a not_blank -> 'a not_blank -> int = + fun _cmp__a a__009_ b__010_ -> + if Stdlib.( == ) a__009_ b__010_ + then 0 + else ( + match compare_string a__009_.trailing_blanks b__010_.trailing_blanks with + | 0 -> + (match compare_string a__009_.orig b__010_.orig with + | 0 -> _cmp__a a__009_.data b__010_.data + | n -> n) + | n -> n) + ;; + + let _ = compare_not_blank + + let equal_not_blank : 'a. ('a -> 'a -> bool) -> 'a not_blank -> 'a not_blank -> bool = + fun _cmp__a a__011_ b__012_ -> + if Stdlib.( == ) a__011_ b__012_ + then true + else + Stdlib.( && ) + (equal_string a__011_.trailing_blanks b__012_.trailing_blanks) + (Stdlib.( && ) + (equal_string a__011_.orig b__012_.orig) + (_cmp__a a__011_.data b__012_.data)) + ;; + + let _ = equal_not_blank + + [@@@end] + + type 'a t = + | Blank of string + | Conflict_marker of string + | Not_blank of 'a not_blank + [@@deriving_inline sexp_of, compare, equal] + + let _ = fun (_ : 'a t) -> () + + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__020_) : ((a__020_ -> Sexplib0.Sexp.t) -> a__020_ t -> Sexplib0.Sexp.t) -> + fun _of_a__013_ -> function + | Blank arg0__014_ -> + let res0__015_ = sexp_of_string arg0__014_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Blank"; res0__015_ ] + | Conflict_marker arg0__016_ -> + let res0__017_ = sexp_of_string arg0__016_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Conflict_marker"; res0__017_ ] + | Not_blank arg0__018_ -> + let res0__019_ = sexp_of_not_blank _of_a__013_ arg0__018_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Not_blank"; res0__019_ ] + ;; + + let _ = sexp_of_t + + let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__021_ b__022_ -> + if Stdlib.( == ) a__021_ b__022_ + then 0 + else ( + match a__021_, b__022_ with + | Blank _a__023_, Blank _b__024_ -> compare_string _a__023_ _b__024_ + | Blank _, _ -> -1 + | _, Blank _ -> 1 + | Conflict_marker _a__025_, Conflict_marker _b__026_ -> + compare_string _a__025_ _b__026_ + | Conflict_marker _, _ -> -1 + | _, Conflict_marker _ -> 1 + | Not_blank _a__027_, Not_blank _b__028_ -> + compare_not_blank _cmp__a _a__027_ _b__028_) + ;; + + let _ = compare + + let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = + fun _cmp__a a__031_ b__032_ -> + if Stdlib.( == ) a__031_ b__032_ + then true + else ( + match a__031_, b__032_ with + | Blank _a__033_, Blank _b__034_ -> equal_string _a__033_ _b__034_ + | Blank _, _ -> false + | _, Blank _ -> false + | Conflict_marker _a__035_, Conflict_marker _b__036_ -> + equal_string _a__035_ _b__036_ + | Conflict_marker _, _ -> false + | _, Conflict_marker _ -> false + | Not_blank _a__037_, Not_blank _b__038_ -> + equal_not_blank _cmp__a _a__037_ _b__038_) + ;; + + let _ = equal + + [@@@end] + + let map t ~f = + match t with + | Blank b -> Blank b + | Conflict_marker c -> Conflict_marker c + | Not_blank n -> Not_blank { n with data = f n.orig n.data } + ;; + + let strip = function + | Blank _ -> Blank "" + | Conflict_marker c -> Conflict_marker (String.rstrip c) + | Not_blank n -> Not_blank { n with trailing_blanks = "" } + ;; + + let invariant inv = function + | Blank s -> assert (is_blanks s) + | Conflict_marker c -> assert (is_conflict_marker c) + | Not_blank n -> + assert (is_blanks n.trailing_blanks); + inv n.data; + assert (no_nl n.orig); + let len = String.length n.orig in + assert (len > 0 && not (is_blank n.orig.[len - 1])) + ;; + + let data t ~blank ~conflict_marker = + match t with + | Blank _ -> blank + | Conflict_marker marker -> conflict_marker marker + | Not_blank n -> n.data + ;; + + let orig = function + | Blank _ -> "" + | Conflict_marker c -> c + | Not_blank n -> n.orig + ;; +end + +type 'a single_line = + { leading_blanks : string + ; trailing_spaces : string + ; orig : string + ; data : 'a + } +[@@deriving_inline sexp_of, compare, equal] + +let _ = fun (_ : 'a single_line) -> () + +let sexp_of_single_line : 'a. ('a -> Sexplib0.Sexp.t) -> 'a single_line -> Sexplib0.Sexp.t + = + fun _of_a__041_ + { leading_blanks = leading_blanks__043_ + ; trailing_spaces = trailing_spaces__045_ + ; orig = orig__047_ + ; data = data__049_ + } -> + let bnds__042_ = ([] : _ Stdlib.List.t) in + let bnds__042_ = + let arg__050_ = _of_a__041_ data__049_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "data"; arg__050_ ] :: bnds__042_ + : _ Stdlib.List.t) + in + let bnds__042_ = + let arg__048_ = sexp_of_string orig__047_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "orig"; arg__048_ ] :: bnds__042_ + : _ Stdlib.List.t) + in + let bnds__042_ = + let arg__046_ = sexp_of_string trailing_spaces__045_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "trailing_spaces"; arg__046_ ] :: bnds__042_ + : _ Stdlib.List.t) + in + let bnds__042_ = + let arg__044_ = sexp_of_string leading_blanks__043_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "leading_blanks"; arg__044_ ] :: bnds__042_ + : _ Stdlib.List.t) + in + Sexplib0.Sexp.List bnds__042_ +;; + +let _ = sexp_of_single_line + +let compare_single_line : 'a. ('a -> 'a -> int) -> 'a single_line -> 'a single_line -> int + = + fun _cmp__a a__051_ b__052_ -> + if Stdlib.( == ) a__051_ b__052_ + then 0 + else ( + match compare_string a__051_.leading_blanks b__052_.leading_blanks with + | 0 -> + (match compare_string a__051_.trailing_spaces b__052_.trailing_spaces with + | 0 -> + (match compare_string a__051_.orig b__052_.orig with + | 0 -> _cmp__a a__051_.data b__052_.data + | n -> n) + | n -> n) + | n -> n) +;; + +let _ = compare_single_line + +let equal_single_line : 'a. ('a -> 'a -> bool) -> 'a single_line -> 'a single_line -> bool + = + fun _cmp__a a__053_ b__054_ -> + if Stdlib.( == ) a__053_ b__054_ + then true + else + Stdlib.( && ) + (equal_string a__053_.leading_blanks b__054_.leading_blanks) + (Stdlib.( && ) + (equal_string a__053_.trailing_spaces b__054_.trailing_spaces) + (Stdlib.( && ) + (equal_string a__053_.orig b__054_.orig) + (_cmp__a a__053_.data b__054_.data))) +;; + +let _ = equal_single_line + +[@@@end] + +type 'a multi_lines = + { leading_spaces : string + ; trailing_spaces : string + ; indentation : string + ; lines : 'a Line.t list + } +[@@deriving_inline sexp_of, compare, equal] + +let _ = fun (_ : 'a multi_lines) -> () + +let sexp_of_multi_lines : 'a. ('a -> Sexplib0.Sexp.t) -> 'a multi_lines -> Sexplib0.Sexp.t + = + fun _of_a__055_ + { leading_spaces = leading_spaces__057_ + ; trailing_spaces = trailing_spaces__059_ + ; indentation = indentation__061_ + ; lines = lines__063_ + } -> + let bnds__056_ = ([] : _ Stdlib.List.t) in + let bnds__056_ = + let arg__064_ = sexp_of_list (Line.sexp_of_t _of_a__055_) lines__063_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "lines"; arg__064_ ] :: bnds__056_ + : _ Stdlib.List.t) + in + let bnds__056_ = + let arg__062_ = sexp_of_string indentation__061_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "indentation"; arg__062_ ] :: bnds__056_ + : _ Stdlib.List.t) + in + let bnds__056_ = + let arg__060_ = sexp_of_string trailing_spaces__059_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "trailing_spaces"; arg__060_ ] :: bnds__056_ + : _ Stdlib.List.t) + in + let bnds__056_ = + let arg__058_ = sexp_of_string leading_spaces__057_ in + (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "leading_spaces"; arg__058_ ] :: bnds__056_ + : _ Stdlib.List.t) + in + Sexplib0.Sexp.List bnds__056_ +;; + +let _ = sexp_of_multi_lines + +let compare_multi_lines : 'a. ('a -> 'a -> int) -> 'a multi_lines -> 'a multi_lines -> int + = + fun _cmp__a a__065_ b__066_ -> + if Stdlib.( == ) a__065_ b__066_ + then 0 + else ( + match compare_string a__065_.leading_spaces b__066_.leading_spaces with + | 0 -> + (match compare_string a__065_.trailing_spaces b__066_.trailing_spaces with + | 0 -> + (match compare_string a__065_.indentation b__066_.indentation with + | 0 -> + compare_list + (fun a__067_ b__068_ -> Line.compare _cmp__a a__067_ b__068_) + a__065_.lines + b__066_.lines + | n -> n) + | n -> n) + | n -> n) +;; + +let _ = compare_multi_lines + +let equal_multi_lines : 'a. ('a -> 'a -> bool) -> 'a multi_lines -> 'a multi_lines -> bool + = + fun _cmp__a a__071_ b__072_ -> + if Stdlib.( == ) a__071_ b__072_ + then true + else + Stdlib.( && ) + (equal_string a__071_.leading_spaces b__072_.leading_spaces) + (Stdlib.( && ) + (equal_string a__071_.trailing_spaces b__072_.trailing_spaces) + (Stdlib.( && ) + (equal_string a__071_.indentation b__072_.indentation) + (equal_list + (fun a__073_ b__074_ -> Line.equal _cmp__a a__073_ b__074_) + a__071_.lines + b__072_.lines))) +;; + +let _ = equal_multi_lines + +[@@@end] + +type 'a t = + | Empty of string + | Single_line of 'a single_line + | Multi_lines of 'a multi_lines +[@@deriving_inline sexp_of, compare, equal] + +let _ = fun (_ : 'a t) -> () + +let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__084_) : ((a__084_ -> Sexplib0.Sexp.t) -> a__084_ t -> Sexplib0.Sexp.t) -> + fun _of_a__077_ -> function + | Empty arg0__078_ -> + let res0__079_ = sexp_of_string arg0__078_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Empty"; res0__079_ ] + | Single_line arg0__080_ -> + let res0__081_ = sexp_of_single_line _of_a__077_ arg0__080_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Single_line"; res0__081_ ] + | Multi_lines arg0__082_ -> + let res0__083_ = sexp_of_multi_lines _of_a__077_ arg0__082_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Multi_lines"; res0__083_ ] +;; + +let _ = sexp_of_t + +let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__085_ b__086_ -> + if Stdlib.( == ) a__085_ b__086_ + then 0 + else ( + match a__085_, b__086_ with + | Empty _a__087_, Empty _b__088_ -> compare_string _a__087_ _b__088_ + | Empty _, _ -> -1 + | _, Empty _ -> 1 + | Single_line _a__089_, Single_line _b__090_ -> + compare_single_line _cmp__a _a__089_ _b__090_ + | Single_line _, _ -> -1 + | _, Single_line _ -> 1 + | Multi_lines _a__093_, Multi_lines _b__094_ -> + compare_multi_lines _cmp__a _a__093_ _b__094_) +;; + +let _ = compare + +let equal : 'a. ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = + fun _cmp__a a__097_ b__098_ -> + if Stdlib.( == ) a__097_ b__098_ + then true + else ( + match a__097_, b__098_ with + | Empty _a__099_, Empty _b__100_ -> equal_string _a__099_ _b__100_ + | Empty _, _ -> false + | _, Empty _ -> false + | Single_line _a__101_, Single_line _b__102_ -> + equal_single_line _cmp__a _a__101_ _b__102_ + | Single_line _, _ -> false + | _, Single_line _ -> false + | Multi_lines _a__105_, Multi_lines _b__106_ -> + equal_multi_lines _cmp__a _a__105_ _b__106_) +;; + +let _ = equal + +[@@@end] + +let invariant inv t = + match t with + | Empty s -> assert (is_spaces s) + | Single_line s -> + assert (is_blanks s.leading_blanks); + assert (is_spaces s.trailing_spaces); + inv s.data; + assert (no_nl s.orig); + let len = String.length s.orig in + assert (len > 0 && (not (is_blank s.orig.[0])) && not (is_blank s.orig.[len - 1])) + | Multi_lines m -> + assert (is_spaces m.leading_spaces); + let ld_len = String.length m.leading_spaces in + assert (ld_len = 0 || Char.equal m.leading_spaces.[ld_len - 1] '\n'); + let tr_has_nl = has_nl m.trailing_spaces in + assert ( + is_spaces m.trailing_spaces + && ((not tr_has_nl) || Char.equal m.trailing_spaces.[0] '\n')); + assert (is_blanks m.indentation); + List.iter m.lines ~f:(Line.invariant inv); + (match m.lines with + | [] -> assert false + | Blank _ :: _ -> assert false + | [ Not_blank n ] -> + assert (ld_len > 0 && (tr_has_nl || String.is_empty n.trailing_blanks)) + | l -> + let rec check_last = function + | ([] : _ Line.t list) -> assert false + | [ Blank _ ] -> assert false + | [ Not_blank n ] -> assert (tr_has_nl || String.is_empty n.trailing_blanks) + | [ Conflict_marker m ] -> assert (not (String.is_empty m)) + | _ :: (_ :: _ as l) -> check_last l + in + check_last l) +;; + +let empty = Empty "" + +let map t ~f = + match t with + | Empty e -> Empty e + | Single_line s -> Single_line { s with data = f s.orig s.data } + | Multi_lines m -> Multi_lines { m with lines = List.map m.lines ~f:(Line.map ~f) } +;; + +let data t ~blank ~conflict_marker = + match t with + | Empty _ -> [] + | Single_line s -> [ s.data ] + | Multi_lines m -> List.map m.lines ~f:(Line.data ~blank ~conflict_marker) +;; + +let stripped_original_lines t = + match t with + | Empty _ -> [] + | Single_line s -> [ s.orig ] + | Multi_lines m -> List.map m.lines ~f:Line.orig +;; + +let line_of_single s : _ Line.t = + Not_blank { trailing_blanks = ""; orig = s.orig; data = s.data } +;; + +let to_lines t = + match t with + | Empty _ -> [] + | Single_line s -> [ line_of_single s ] + | Multi_lines m -> m.lines +;; + +let strip t = + match t with + | Empty _ -> Empty "" + | Single_line s -> Single_line { s with leading_blanks = ""; trailing_spaces = "" } + | Multi_lines m -> + (match m.lines with + | [] -> Empty "" + | [ Blank _ ] -> assert false + | [ Not_blank n ] -> + Single_line + { leading_blanks = ""; trailing_spaces = ""; orig = n.orig; data = n.data } + | lines -> + Multi_lines + { leading_spaces = "" + ; trailing_spaces = "" + ; indentation = "" + ; lines = List.map lines ~f:Line.strip + }) +;; + +let to_string t = + match t with + | Empty s -> s + | Single_line s -> s.leading_blanks ^ s.orig ^ s.trailing_spaces + | Multi_lines m -> + let indent (line : _ Line.t) = + match line with + | Blank b -> b + | Conflict_marker c -> c + | Not_blank n -> m.indentation ^ n.orig ^ n.trailing_blanks + in + let s = List.map m.lines ~f:indent |> String.concat ~sep:"\n" in + m.leading_spaces ^ s ^ m.trailing_spaces +;; + +let trim_lines lines = + let rec loop0 : _ Line.t list -> _ = function + | Blank _ :: l -> loop0 l + | l -> loop1 l ~acc:[] ~acc_with_trailing_blanks:[] + and loop1 ~acc ~acc_with_trailing_blanks = function + | (Blank _ as x) :: l -> + loop1 l ~acc ~acc_with_trailing_blanks:(x :: acc_with_trailing_blanks) + | ((Conflict_marker _ | Not_blank _) as x) :: l -> + let acc = x :: acc_with_trailing_blanks in + loop1 l ~acc ~acc_with_trailing_blanks:acc + | [] -> List.rev acc + in + loop0 lines +;; + +let not_blank_or_conflict_lines lines = + List.fold_left lines ~init:[] ~f:(fun acc (l : _ Line.t) -> + match l with + | Blank _ | Conflict_marker _ -> acc + | Not_blank n -> n.orig :: acc) + |> List.rev +;; + +let longest_common_prefix a b = + let len_a = String.length a in + let len_b = String.length b in + let len = min len_a len_b in + let i = ref 0 in + while !i < len && Char.equal a.[!i] b.[!i] do + Int.incr i + done; + String.sub a ~pos:0 ~len:!i +;; + +let indentation s = + let len = String.length s in + let i = ref 0 in + while !i < len && is_blank s.[!i] do + Int.incr i + done; + String.sub s ~pos:0 ~len:!i +;; + +let extract_indentation lines = + match not_blank_or_conflict_lines lines with + | [] -> "", lines + | first :: rest -> + let indent = List.fold_left rest ~init:(indentation first) ~f:longest_common_prefix in + let indent_len = String.length indent in + let update_line : 'a Line.t -> 'a Line.t = function + | Blank b -> Blank b + | Conflict_marker c -> Conflict_marker c + | Not_blank n -> + let orig = + String.sub n.orig ~pos:indent_len ~len:(String.length n.orig - indent_len) + in + Not_blank { n with orig } + in + indent, List.map lines ~f:update_line +;; + +let break s at = String.prefix s at, String.drop_prefix s at + +let reconcile (type a) t ~lines ~default_indentation ~pad_single_line = + let module M = struct + type t = + | Empty + | Single_line of a Line.not_blank + | Multi_lines of a Line.t list + end + in + let lines = + match trim_lines lines |> extract_indentation |> snd with + | [] -> M.Empty + | [ Blank _ ] -> assert false + | [ Not_blank n ] -> M.Single_line n + | lines -> M.Multi_lines lines + in + let padding = if pad_single_line then " " else "" in + let res = + match t, lines with + | Empty _, Empty -> t + | Single_line s, Single_line n -> Single_line { s with orig = n.orig; data = n.data } + | Multi_lines m, Multi_lines l -> Multi_lines { m with lines = l } + | Empty e, Multi_lines l -> + let ld, tr = + if has_nl e + then ( + let ld, tr = break e (String.index_exn e '\n') in + ld ^ "\n", tr) + else "\n", padding + in + Multi_lines + { leading_spaces = ld + ; trailing_spaces = tr + ; indentation = String.make (default_indentation + 2) ' ' + ; lines = l + } + | Single_line m, Multi_lines l -> + Multi_lines + { leading_spaces = "\n" + ; trailing_spaces = m.trailing_spaces + ; indentation = String.make (default_indentation + 2) ' ' + ; lines = l + } + | Single_line _, Empty | Multi_lines _, Empty -> Empty padding + | Empty _, Single_line n -> + Single_line + { orig = n.orig + ; data = n.data + ; leading_blanks = padding + ; trailing_spaces = padding + } + | Multi_lines m, Single_line n -> Multi_lines { m with lines = [ Not_blank n ] } + in + invariant ignore res; + res +;; diff --git a/matcher/cst.mli b/matcher/cst.mli new file mode 100644 index 0000000..a91ef78 --- /dev/null +++ b/matcher/cst.mli @@ -0,0 +1,195 @@ +(** Concrete syntax tree of expectations and actual outputs *) + +(** These types represent the contents of an [%expect] node or of the actual output. We + keep information about the original layout so that we can give an corrected + expectation that follows the original formatting. + + In the following names, blank means ' ' or '\t', while space means blank or newline. +*) + +open! Base +open Base.Exported_for_specific_uses (* for [Ppx_compare_lib] *) + +module Line : sig + type 'a not_blank = + { trailing_blanks : string (** regexp: "[ \t]*" *) + ; orig : string + (** Original contents of the line without the trailing blanks or indentation. + regexp: "[^\n]*[^ \t\n]" *) + ; data : 'a + (** Data associated to the line. *) + } + [@@deriving_inline sexp_of, compare, equal] + + include + sig + [@@@ocaml.warning "-32"] + val sexp_of_not_blank : + ('a -> Sexplib0.Sexp.t) -> 'a not_blank -> Sexplib0.Sexp.t + val compare_not_blank : + ('a -> 'a -> int) -> 'a not_blank -> 'a not_blank -> int + val equal_not_blank : + ('a -> 'a -> bool) -> 'a not_blank -> 'a not_blank -> bool + end[@@ocaml.doc "@inline"] + [@@@end] + + type 'a t = + | Blank of string (** regexp: "[ \t]*" *) + | Conflict_marker of string (** regexp: "^(<{7} |[|]{7} |>{7} |={7})" *) + | Not_blank of 'a not_blank + [@@deriving_inline sexp_of, compare, equal] + + + include + sig + [@@@ocaml.warning "-32"] + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t + end[@@ocaml.doc "@inline"] + [@@@end] + + val invariant : ('a -> unit) -> 'a t -> unit + + (** The callback receive the [orig] and [data] fields *) + val map : 'a t -> f:(string -> 'a -> 'b) -> 'b t + + (** Delete trailing blanks (everything for blank lines) *) + val strip : 'a t -> 'a t + + val data : 'a t -> blank:'a -> conflict_marker:(string -> 'a) -> 'a +end + +(** Single line represent [%expect] nodes with data on the first line but not on the + subsequent ones. + + For instance: + + {[ + [%expect " blah "]; + [%expect {| blah + |}] + ]} +*) +type 'a single_line = + { leading_blanks : string (** regexp: "[ \t]*" *) + ; trailing_spaces : string (** regexp: "[ \t\n]*" *) + ; orig : string (** regexp: "[^ \t\n]([^\n]*[^ \t\n])?" *) + ; data : 'a + } +[@@deriving_inline sexp_of, compare, equal] +include + sig + [@@@ocaml.warning "-32"] + val sexp_of_single_line : + ('a -> Sexplib0.Sexp.t) -> 'a single_line -> Sexplib0.Sexp.t + val compare_single_line : + ('a -> 'a -> int) -> 'a single_line -> 'a single_line -> int + val equal_single_line : + ('a -> 'a -> bool) -> 'a single_line -> 'a single_line -> bool + end[@@ocaml.doc "@inline"] +[@@@end] + +(** Any [%expect] node with one or more newlines and at least one non-blank line. + + This also include the case with exactly one non-blank line such as: + + {[ + [%expect {| + blah + |}] + ]} + + This is to preserve this formatting in case the correction is multi-line. + + [leading_spaces] contains everything until the first non-blank line, while + [trailing_spaces] is either: + + - trailing blanks on the last line if of the form: + + {[ + [%expect {| + abc + def |}] + ]} + + - all trailing spaces from the newline character (inclusive) on the last non-blank + line to the end if of the form: + + {[ + [%expect {| + abc + def + |}] + ]} +*) +type 'a multi_lines = + { leading_spaces : string (** regexp: "\([ \t]*\n\)*" *) + ; trailing_spaces : string (** regexp: "[ \t]*" or "\(\n[ \t]*\)*" *) + ; indentation : string (** regexp: "[ \t]*" *) + ; lines : 'a Line.t list (** regexp: not_blank (.* not_blank)? *) + } +[@@deriving_inline sexp_of, compare, equal] +include + sig + [@@@ocaml.warning "-32"] + val sexp_of_multi_lines : + ('a -> Sexplib0.Sexp.t) -> 'a multi_lines -> Sexplib0.Sexp.t + val compare_multi_lines : + ('a -> 'a -> int) -> 'a multi_lines -> 'a multi_lines -> int + val equal_multi_lines : + ('a -> 'a -> bool) -> 'a multi_lines -> 'a multi_lines -> bool + end[@@ocaml.doc "@inline"] +[@@@end] + +type 'a t = + | Empty of string (** regexp: "[ \t\n]*" *) + | Single_line of 'a single_line + | Multi_lines of 'a multi_lines +[@@deriving_inline sexp_of, compare, equal] +include + sig + [@@@ocaml.warning "-32"] + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t + end[@@ocaml.doc "@inline"] +[@@@end] + +val invariant : ('a -> unit) -> 'a t -> unit + +val empty : 'a t + +val map : 'a t -> f:(string -> 'a -> 'b) -> 'b t + +val data : 'a t -> blank:'a -> conflict_marker:(string -> 'a) -> 'a list + +val strip : 'a t -> 'a t + +val to_string : _ t -> string + +(** For single line expectation, leading blanks and trailing spaces are dropped. *) +val to_lines : 'a t -> 'a Line.t list + +(** Remove blank lines at the beginning and end of the list. *) +val trim_lines : 'a Line.t list -> 'a Line.t list + +(** Given a contents [t] and a list of [lines], try to produce a new contents containing + [lines] but with the same formatting as [t]. + + [default_indentation] is the indentation to use in case we ignore [t]'s indentation + (for instance if [t] is [Single_line] or [Empty]). *) +val reconcile + : 'a t + -> lines : 'a Line.t list + -> default_indentation : int + -> pad_single_line : bool + -> 'a t + +(** Compute the longest indentation of a list of lines and trim it from every line. It + returns the found indentation and the list of trimmed lines. *) +val extract_indentation : 'a Line.t list -> string * 'a Line.t list + +(** All the [.orig] fields of [Line.t] or [single_line] values, using [""] for blank + lines. *) +val stripped_original_lines : _ t -> string list diff --git a/matcher/dune b/matcher/dune new file mode 100644 index 0000000..5415908 --- /dev/null +++ b/matcher/dune @@ -0,0 +1,7 @@ +(library (name expect_test_matcher) (public_name ppx_expect.matcher) + (libraries base re expect_test_common expect_test_config_types + ppx_inline_test.runtime-lib) + (preprocess no_preprocessing) + (lint (pps ppx_base ppx_base_lint -apply=js_style,base_lint,type_conv))) + +(ocamllex lexer)
\ No newline at end of file diff --git a/matcher/expect_test_matcher.ml b/matcher/expect_test_matcher.ml new file mode 100644 index 0000000..3202a27 --- /dev/null +++ b/matcher/expect_test_matcher.ml @@ -0,0 +1,11 @@ +module Std = struct + module Choose_tag = Choose_tag + module Cst = Cst + module Fmt = Fmt + module Lexer = Lexer + module Matcher = Matcher + module Reconcile = Reconcile +end +[@@deprecated "[since 2020-03] use [Expect_test_matcher] instead"] + +include Std [@@alert "-deprecated"] diff --git a/matcher/fmt.ml b/matcher/fmt.ml new file mode 100644 index 0000000..9e92cb7 --- /dev/null +++ b/matcher/fmt.ml @@ -0,0 +1,66 @@ +open! Base +open Import +open Ppx_compare_lib.Builtin +open Sexplib0.Sexp_conv + +type t = + | Regexp of string + | Glob of string + | Literal of string +[@@deriving_inline sexp_of, compare, equal] + +let _ = fun (_ : t) -> () + +let sexp_of_t = + (function + | Regexp arg0__001_ -> + let res0__002_ = sexp_of_string arg0__001_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Regexp"; res0__002_ ] + | Glob arg0__003_ -> + let res0__004_ = sexp_of_string arg0__003_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Glob"; res0__004_ ] + | Literal arg0__005_ -> + let res0__006_ = sexp_of_string arg0__005_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Literal"; res0__006_ ] + : t -> Sexplib0.Sexp.t) +;; + +let _ = sexp_of_t + +let compare = + (fun a__007_ b__008_ -> + if Stdlib.( == ) a__007_ b__008_ + then 0 + else ( + match a__007_, b__008_ with + | Regexp _a__009_, Regexp _b__010_ -> compare_string _a__009_ _b__010_ + | Regexp _, _ -> -1 + | _, Regexp _ -> 1 + | Glob _a__011_, Glob _b__012_ -> compare_string _a__011_ _b__012_ + | Glob _, _ -> -1 + | _, Glob _ -> 1 + | Literal _a__013_, Literal _b__014_ -> compare_string _a__013_ _b__014_) + : t -> t -> int) +;; + +let _ = compare + +let equal = + (fun a__015_ b__016_ -> + if Stdlib.( == ) a__015_ b__016_ + then true + else ( + match a__015_, b__016_ with + | Regexp _a__017_, Regexp _b__018_ -> equal_string _a__017_ _b__018_ + | Regexp _, _ -> false + | _, Regexp _ -> false + | Glob _a__019_, Glob _b__020_ -> equal_string _a__019_ _b__020_ + | Glob _, _ -> false + | _, Glob _ -> false + | Literal _a__021_, Literal _b__022_ -> equal_string _a__021_ _b__022_) + : t -> t -> bool) +;; + +let _ = equal + +[@@@end] diff --git a/matcher/fmt.mli b/matcher/fmt.mli new file mode 100644 index 0000000..20f2c36 --- /dev/null +++ b/matcher/fmt.mli @@ -0,0 +1,22 @@ +(** Representation of parsed [%expect] lines *) + +open! Base +open Base.Exported_for_specific_uses (* for [Ppx_compare_lib] *) + +type t = + | Regexp of string + | Glob of string + | Literal of string +[@@deriving_inline sexp_of, compare, equal] + +include sig + [@@@ocaml.warning "-32"] + + val sexp_of_t : t -> Sexplib0.Sexp.t + + include Ppx_compare_lib.Comparable.S with type t := t + include Ppx_compare_lib.Equal.S with type t := t +end +[@@ocaml.doc "@inline"] + +[@@@end] diff --git a/matcher/import.ml b/matcher/import.ml new file mode 100644 index 0000000..1640542 --- /dev/null +++ b/matcher/import.ml @@ -0,0 +1 @@ +module Ppx_compare_lib = Base.Exported_for_specific_uses.Ppx_compare_lib diff --git a/matcher/lexer.mli b/matcher/lexer.mli new file mode 100644 index 0000000..ce69c00 --- /dev/null +++ b/matcher/lexer.mli @@ -0,0 +1,15 @@ +open Expect_test_common + +(** Strip all surrounding whitespace and return the result as a list of lines *) +val strip_surrounding_whitespaces : string -> unit Cst.t + + +val parse_pretty_line : allow_output_patterns:bool -> string -> Fmt.t +val parse_pretty : allow_output_patterns:bool -> string -> Fmt.t Cst.t + +val parse_body + : allow_output_patterns:bool + -> string Expectation.Body.t + -> Fmt.t Cst.t Expectation.Body.t + +val extract_quoted_string_terminators : string -> string list diff --git a/matcher/lexer.mll b/matcher/lexer.mll new file mode 100644 index 0000000..afb786e --- /dev/null +++ b/matcher/lexer.mll @@ -0,0 +1,139 @@ +{ + open Expect_test_common + open Sexplib0.Sexp_conv + + let escaped s = + let unescaped = Scanf.unescaped s in + (* [test/test_matcher.ml] tests the behavior of [Scanf.unescaped] on newlines. *) + if String.contains unescaped '\n' + then + failwith "(escaped) strings can't contain escaped newlines"; + Fmt.Literal unescaped +} + +let space = [' ' '\t'] +let line_contents = [^' ' '\t' '\n']+ (space* [^' ' '\t' '\n']+)* +let lowercase = ['a'-'z' '_'] + +let conflict_marker = "<<<<<<< " line_contents space* + | "||||||| " line_contents space* + | "=======" + | ">>>>>>> " line_contents space* + +rule pretty_line = parse + | space* line_contents as s space* "(escaped)" eof { escaped s } + | space* line_contents as s space* "(literal)" eof { Literal s } + | space* line_contents as s space* "(regexp)" eof { Regexp s } + | space* line_contents as s space* "(glob)" eof { Glob s } + | space* line_contents as s eof { Literal s } + | space* eof { Literal "" } + | _* as s { Printf.ksprintf invalid_arg "Lexer.pretty_line %S" s } + +and pretty_line_no_output_patterns = parse + | space* line_contents as s eof { Fmt.Literal s } + | space* eof { Literal "" } + | _* as s { Printf.ksprintf invalid_arg + "Lexer.pretty_line_no_output_patterns %S" s } + +and leading_spaces = parse + | (space* '\n')* as s { s } + +and lines_with_identation acc = parse + | conflict_marker as c '\n' + { let line = Cst.Line.Conflict_marker c in + lines_with_identation (line :: acc) lexbuf + } + | space* as sp '\n' + { let line = Cst.Line.Blank sp in + lines_with_identation (line :: acc) lexbuf + } + | (space | '\n')* as tr eof + { (List.rev acc, + (* Add the newline that was consumed by the previous line. Since + [lines_with_identation] is never called on blank strings, we know there is such + a line. *) + "\n" ^ tr) } + | space* line_contents as s (space* as tr) eof + { let line = + Cst.Line.Not_blank + { orig = s + ; data = () + ; trailing_blanks = "" + } + in + (List.rev (line :: acc), tr) + } + | space* line_contents as s (space* as tr) '\n' + { let line = + Cst.Line.Not_blank + { orig = s + ; data = () + ; trailing_blanks = tr + } + in + lines_with_identation (line :: acc) lexbuf + } + +and strip_surrounding_whitespaces = parse + | (space | '\n')* eof as s + { Cst.Empty s } + | (space* as leading) (line_contents as s) ((space | '\n')* as trailing) eof + { Cst.Single_line + { leading_blanks = leading + ; trailing_spaces = trailing + ; orig = s + ; data = () + } + } + | "" + { let leading_spaces = leading_spaces lexbuf in + let lines, trailing_spaces = lines_with_identation [] lexbuf in + let indentation, lines = Cst.extract_indentation lines in + Cst.Multi_lines + { trailing_spaces + ; leading_spaces + ; indentation + ; lines + } + } + +and quoted_string_terminators acc = parse + | "|" (lowercase* as s) "}" { quoted_string_terminators (s :: acc) lexbuf } + | _ { quoted_string_terminators acc lexbuf } + | eof { acc } + +{ + let strip_surrounding_whitespaces s = + let lexbuf = Lexing.from_string s in + let contents = strip_surrounding_whitespaces lexbuf in + Cst.invariant ignore contents; + contents + + let parse_pretty_line ~allow_output_patterns s = + let lexbuf = Lexing.from_string s in + if allow_output_patterns then + pretty_line lexbuf + else + pretty_line_no_output_patterns lexbuf + + let parse_pretty ~allow_output_patterns s = + let res = + Cst.map (strip_surrounding_whitespaces s) + ~f:(fun s () -> + parse_pretty_line ~allow_output_patterns s) + in + (match Ppx_inline_test_lib.testing with + | `Testing `Am_test_runner -> + let cst = Cst.to_string res in + if not (String.equal cst s) + then + failwith (Printf.sprintf "ppx_expect internal error: expected: %S, got: %S" s cst) + | `Testing `Am_child_of_test_runner | `Not_testing -> ()); + res + + let parse_body ~allow_output_patterns body = + Expectation.Body.map_pretty body ~f:(parse_pretty ~allow_output_patterns) + + let extract_quoted_string_terminators s = + quoted_string_terminators [] (Lexing.from_string s) +} diff --git a/matcher/matcher.ml b/matcher/matcher.ml new file mode 100644 index 0000000..16fae26 --- /dev/null +++ b/matcher/matcher.ml @@ -0,0 +1,464 @@ +open Base +open Expect_test_common + +let bprintf = Printf.bprintf + +module Saved_output = struct + type t = + | One of string + | Many_distinct of string list + + let of_nonempty_list_exn outputs = + let _, rev_deduped_preserving_order = + List.fold + outputs + ~init:(Set.empty (module String), []) + ~f:(fun (as_set, as_list) output -> + if Set.mem as_set output + then as_set, as_list + else Set.add as_set output, output :: as_list) + in + match List.rev rev_deduped_preserving_order with + | [] -> failwith "Saved_output.of_nonempty_list_exn got an empty list" + | [ output ] -> One output + | outputs -> Many_distinct outputs + ;; + + let to_list = function + | One s -> [ s ] + | Many_distinct many -> many + ;; + + let merge t1 t2 = of_nonempty_list_exn (to_list t1 @ to_list t2) +end + +module Test_outcome = struct + module Expectations = struct + type t = Fmt.t Cst.t Expectation.t Map.M(File.Location).t + [@@deriving_inline compare, equal] + + let _ = fun (_ : t) -> () + + let compare = + (fun a__001_ b__002_ -> + Map.compare_m__t + (module File.Location) + (fun a__003_ b__004_ -> + Expectation.compare + (fun a__005_ b__006_ -> Cst.compare Fmt.compare a__005_ b__006_) + a__003_ + b__004_) + a__001_ + b__002_ + : t -> t -> int) + ;; + + let _ = compare + + let equal = + (fun a__009_ b__010_ -> + Map.equal_m__t + (module File.Location) + (fun a__011_ b__012_ -> + Expectation.equal + (fun a__013_ b__014_ -> Cst.equal Fmt.equal a__013_ b__014_) + a__011_ + b__012_) + a__009_ + b__010_ + : t -> t -> bool) + ;; + + let _ = equal + + [@@@end] + end + + type t = + { expectations : Expectations.t + ; uncaught_exn_expectation : Fmt.t Cst.t Expectation.t option + ; saved_output : Saved_output.t Map.M(File.Location).t + ; trailing_output : Saved_output.t + ; uncaught_exn : Saved_output.t option + ; upon_unreleasable_issue : Expect_test_config_types.Upon_unreleasable_issue.t + } + + let merge_exn + t + { expectations + ; uncaught_exn_expectation + ; saved_output + ; trailing_output + ; uncaught_exn + ; upon_unreleasable_issue + } + = + if not (Expectations.equal t.expectations expectations) + then failwith "merging tests of different expectations"; + if not + (Expect_test_config_types.Upon_unreleasable_issue.equal + t.upon_unreleasable_issue + upon_unreleasable_issue) + then failwith "merging tests of different [Upon_unreleasable_issue]"; + if not + (Option.equal + (Expectation.equal (Cst.equal Fmt.equal)) + t.uncaught_exn_expectation + uncaught_exn_expectation) + then failwith "merging tests of different uncaught exception expectations"; + { expectations + ; uncaught_exn_expectation + ; saved_output = + Map.merge t.saved_output saved_output ~f:(fun ~key:_ -> function + | `Left x -> Some x + | `Right x -> Some x + | `Both (x, y) -> Some (Saved_output.merge x y)) + ; uncaught_exn = + (match t.uncaught_exn, uncaught_exn with + | None, None -> None + | Some x, None | None, Some x -> Some x + | Some x, Some y -> Some (Saved_output.merge x y)) + ; trailing_output = Saved_output.merge t.trailing_output trailing_output + ; upon_unreleasable_issue + } + ;; +end + +module Test_correction = struct + module Node_correction = struct + type t = + | Collector_never_triggered + | Correction of Fmt.t Cst.t Expectation.Body.t + end + + module Uncaught_exn = struct + type t = + | Match + | Without_expectation of Fmt.t Cst.t Expectation.Body.t + | Correction of Fmt.t Cst.t Expectation.t * Fmt.t Cst.t Expectation.Body.t + | Unused_expectation of Fmt.t Cst.t Expectation.t + end + + type t = + { location : File.Location.t + ; (* In the order of the file *) + corrections : (Fmt.t Cst.t Expectation.t * Node_correction.t) list + ; uncaught_exn : Uncaught_exn.t + ; trailing_output : Fmt.t Cst.t Expectation.Body.t Reconcile.Result.t + } + + let map_corrections t ~f = + { location = t.location + ; corrections = + List.map t.corrections ~f:(fun (e, c) -> + ( e + , match c with + | Collector_never_triggered -> c + | Correction body -> Correction (Expectation.Body.map_pretty body ~f) )) + ; uncaught_exn = + (match t.uncaught_exn with + | (Match | Unused_expectation _) as x -> x + | Without_expectation body -> + Without_expectation (Expectation.Body.map_pretty body ~f) + | Correction (e, body) -> Correction (e, Expectation.Body.map_pretty body ~f)) + ; trailing_output = + Reconcile.Result.map t.trailing_output ~f:(Expectation.Body.map_pretty ~f) + } + ;; + + let compare_locations a b = compare a.location.line_number b.location.line_number + + let make ~location ~corrections ~uncaught_exn ~trailing_output : t Reconcile.Result.t = + if List.is_empty corrections + && (match (trailing_output : _ Reconcile.Result.t) with + | Match -> true + | Correction _ -> false) + && + match (uncaught_exn : Uncaught_exn.t) with + | Match -> true + | Correction _ | Without_expectation _ | Unused_expectation _ -> false + then Match + else Correction { location; corrections; uncaught_exn; trailing_output } + ;; +end + +let indentation_at file_contents (loc : File.Location.t) = + let n = ref loc.line_start in + while Char.equal file_contents.[!n] ' ' do + Int.incr n + done; + !n - loc.line_start +;; + +let evaluate_test + ~file_contents + ~(location : File.Location.t) + ~allow_output_patterns + (test : Test_outcome.t) + = + let cr_for_multiple_outputs ~cr_body outputs = + let prefix = + Expect_test_config_types.Upon_unreleasable_issue.comment_prefix + test.upon_unreleasable_issue + in + let cr = Printf.sprintf "(* %sexpect_test: %s *)" prefix cr_body in + let sep = String.init (String.length cr) ~f:(fun _ -> '=') in + List.intersperse (cr :: outputs) ~sep |> String.concat ~sep:"\n" + in + let corrections = + Map.to_alist test.expectations + |> List.filter_map ~f:(fun (location, (expect : Fmt.t Cst.t Expectation.t)) -> + let correction_for actual = + let default_indent = indentation_at file_contents expect.body_location in + match + Reconcile.expectation_body + ~expect:expect.body + ~actual + ~default_indent + ~pad_single_line:(Option.is_some expect.tag) + ~allow_output_patterns + with + | Match -> None + | Correction c -> Some (expect, Test_correction.Node_correction.Correction c) + in + match Map.find test.saved_output location with + | None -> + (match expect.body with + | Unreachable | Output -> None + | Exact _ | Pretty _ -> + Some (expect, Test_correction.Node_correction.Collector_never_triggered)) + | Some (One actual) -> correction_for actual + | Some (Many_distinct outputs) -> + let matches_expectation output = Option.is_none (correction_for output) in + if List.for_all outputs ~f:matches_expectation + then None + else + cr_for_multiple_outputs + outputs + ~cr_body:"Collector ran multiple times with different outputs" + |> correction_for) + in + let trailing_output = + let indent = location.start_pos - location.line_start + 2 in + let actual = + match test.trailing_output with + | One actual -> actual + | Many_distinct outputs -> + cr_for_multiple_outputs + outputs + ~cr_body:"Test ran multiple times with different trailing outputs" + in + Reconcile.expectation_body + ~expect:(Pretty Cst.empty) + ~actual + ~default_indent:indent + ~pad_single_line:true + ~allow_output_patterns + in + let uncaught_exn : Test_correction.Uncaught_exn.t = + match test.uncaught_exn with + | None -> + (match test.uncaught_exn_expectation with + | None -> Match + | Some e -> Unused_expectation e) + | Some x -> + let indent = location.start_pos - location.line_start in + let actual = + match x with + | One actual -> actual + | Many_distinct outputs -> + cr_for_multiple_outputs + outputs + ~cr_body:"Test ran multiple times with different uncaught exceptions" + in + let expect = + match test.uncaught_exn_expectation with + | None -> Expectation.Body.Pretty Cst.empty + | Some e -> e.body + in + (match + Reconcile.expectation_body + ~expect + ~actual + ~default_indent:indent + ~pad_single_line:true + ~allow_output_patterns + with + | Match -> Match + | Correction c -> + (match test.uncaught_exn_expectation with + | None -> Without_expectation c + | Some e -> Correction (e, c))) + in + Test_correction.make ~location ~corrections ~uncaught_exn ~trailing_output +;; + +type mode = + | Inline_expect_test + | Toplevel_expect_test + +let output_slice buf s a b = Buffer.add_string buf (String.sub s ~pos:a ~len:(b - a)) + +let is_space = function + | '\t' | '\011' | '\012' | '\r' | ' ' | '\n' -> true + | _ -> false +;; + +let rec output_semi_colon_if_needed buf file_contents pos = + if pos >= 0 + then ( + match file_contents.[pos] with + | c when is_space c -> output_semi_colon_if_needed buf file_contents (pos - 1) + | ';' -> () + | _ -> Buffer.add_char buf ';') +;; + +let split_lines s = String.split s ~on:'\n' + +let output_corrected buf ~file_contents ~mode test_corrections = + let id_and_string_of_body : _ Expectation.Body.t -> string * string = function + | Exact x -> "expect_exact", x + | Output -> "expect.output", "" + | Pretty x -> "expect", Cst.to_string x + | Unreachable -> assert false + in + let output_body buf tag body = + match tag with + | None -> + bprintf + buf + "\"%s\"" + (String.concat ~sep:"\n" (split_lines body |> List.map ~f:String.escaped)) + | Some tag -> + let tag = Choose_tag.choose ~default:tag body in + bprintf buf "{%s|%s|%s}" tag body tag + in + let ofs = + List.fold_left + test_corrections + ~init:0 + ~f:(fun ofs (test_correction : Test_correction.t) -> + let test_correction, to_skip = + (* If we need to remove an [%%expect.uncaught_exn] node, start by adjusting the + end position of the test. *) + match test_correction.uncaught_exn with + | Unused_expectation e -> + (* Unfortunately, the OCaml parser doesn't give us the location of the whole + extension point, so we have to find the square brackets ourselves :( *) + let start = ref e.extid_location.start_pos in + while not (Char.equal file_contents.[!start] '[') do + if Int.( >= ) ofs !start + then + raise_s + (Sexp.message + "Cannot find '[' marking the start of [%expect.uncaught_exn]" + [ "ofs", Int.sexp_of_t ofs + ; "start", Int.sexp_of_t e.extid_location.start_pos + ]); + Int.decr start + done; + while !start - 1 > ofs && is_space file_contents.[!start - 1] do + Int.decr start + done; + let file_len = String.length file_contents in + let stop = ref e.body_location.end_pos in + while !stop < file_len && not (Char.equal file_contents.[!stop] ']') do + Int.incr stop + done; + if Int.( >= ) !stop file_len + then + raise_s + (Sexp.message + "Cannot find ']' marking the end of [%expect.uncaught_exn]" + [ "stop", Int.sexp_of_t e.body_location.end_pos ]); + Int.incr stop; + let test_correction = + { test_correction with + location = { test_correction.location with end_pos = !start } + } + in + test_correction, Some (!start, !stop) + | Match | Without_expectation _ | Correction _ -> test_correction, None + in + let ofs = + List.fold_left + test_correction.corrections + ~init:ofs + ~f:(fun ofs (e, correction) -> + match (correction : Test_correction.Node_correction.t) with + | Collector_never_triggered -> + output_slice buf file_contents ofs e.Expectation.extid_location.start_pos; + bprintf buf "expect.unreachable"; + e.body_location.end_pos + | Correction c -> + let id, body = id_and_string_of_body c in + output_slice buf file_contents ofs e.extid_location.start_pos; + Buffer.add_string buf id; + output_slice + buf + file_contents + e.extid_location.end_pos + e.body_location.start_pos; + output_body buf e.tag body; + e.body_location.end_pos) + in + let ofs = + match test_correction.trailing_output with + | Match -> ofs + | Correction c -> + let loc = test_correction.location in + output_slice buf file_contents ofs loc.end_pos; + if match mode with + | Inline_expect_test -> true + | Toplevel_expect_test -> false + then output_semi_colon_if_needed buf file_contents loc.end_pos; + let id, body = id_and_string_of_body c in + (match mode with + | Inline_expect_test -> + let indent = loc.start_pos - loc.line_start + 2 in + bprintf buf "\n%*s[%%%s " indent "" id + | Toplevel_expect_test -> + if loc.end_pos = 0 || Char.( <> ) file_contents.[loc.end_pos - 1] '\n' + then Buffer.add_char buf '\n'; + bprintf buf "[%%%%%s" id); + output_body buf (Some "") body; + bprintf buf "]"; + loc.end_pos + in + let ofs = + match test_correction.uncaught_exn with + | Match -> ofs + | Unused_expectation _ -> + (* handled above *) + ofs + | Without_expectation c -> + let loc = test_correction.location in + output_slice buf file_contents ofs loc.end_pos; + let indent = loc.start_pos - loc.line_start in + bprintf buf "\n%*s[@@expect.uncaught_exn " indent ""; + output_body buf (Some "") (snd (id_and_string_of_body c)); + bprintf buf "]"; + loc.end_pos + | Correction (e, c) -> + output_slice buf file_contents ofs e.body_location.start_pos; + output_body buf e.tag (snd (id_and_string_of_body c)); + e.body_location.end_pos + in + match to_skip with + | None -> ofs + | Some (start, stop) -> + output_slice buf file_contents ofs start; + stop) + in + output_slice buf file_contents ofs (String.length file_contents) +;; + +let get_contents_for_corrected_file ~file_contents ~mode test_corrections = + let buf = Buffer.create 4096 in + output_corrected + buf + ~file_contents + ~mode + (List.sort test_corrections ~compare:Test_correction.compare_locations); + Buffer.contents buf +;; diff --git a/matcher/matcher.mli b/matcher/matcher.mli new file mode 100644 index 0000000..8bcde2c --- /dev/null +++ b/matcher/matcher.mli @@ -0,0 +1,71 @@ +open Base +open Expect_test_common + +module Saved_output : sig + type t + + val of_nonempty_list_exn : string list -> t +end + +module Test_outcome : sig + (** Outcome of a group of test. Either a single [let%expect_test], or a whole file for + toplevel expect test. *) + type t = + { expectations : Fmt.t Cst.t Expectation.t Map.M(File.Location).t + ; uncaught_exn_expectation : Fmt.t Cst.t Expectation.t option + ; saved_output : Saved_output.t Map.M(File.Location).t + ; trailing_output : Saved_output.t + ; uncaught_exn : Saved_output.t option + ; upon_unreleasable_issue : Expect_test_config_types.Upon_unreleasable_issue.t + } + + (* Merge two [t]s with the same expectations *) + val merge_exn : t -> t -> t +end + +module Test_correction : sig + (** Correction for one [Test_outcome.t] *) + type t + + val map_corrections : t -> f:(Fmt.t Cst.t -> Fmt.t Cst.t) -> t + + module Node_correction : sig + (** Single node correction *) + type t = + | Collector_never_triggered + | Correction of Fmt.t Cst.t Expectation.Body.t + end + + module Uncaught_exn : sig + type t = + | Match + | Without_expectation of Fmt.t Cst.t Expectation.Body.t + | Correction of Fmt.t Cst.t Expectation.t * Fmt.t Cst.t Expectation.Body.t + | Unused_expectation of Fmt.t Cst.t Expectation.t + end + + val make + : location:File.Location.t + -> corrections:(Fmt.t Cst.t Expectation.t * Node_correction.t) list + -> uncaught_exn:Uncaught_exn.t + -> trailing_output:Fmt.t Cst.t Expectation.Body.t Reconcile.Result.t + -> t Reconcile.Result.t +end + +(** Evaluate the results of all the tests run through Expect_test_runner. *) +val evaluate_test + : file_contents:string + -> location:File.Location.t + -> allow_output_patterns:bool + -> Test_outcome.t + -> Test_correction.t Reconcile.Result.t + +type mode = + | Inline_expect_test + | Toplevel_expect_test + +val get_contents_for_corrected_file + : file_contents:string + -> mode:mode + -> Test_correction.t list + -> string diff --git a/matcher/reconcile.ml b/matcher/reconcile.ml new file mode 100644 index 0000000..6c8dbdd --- /dev/null +++ b/matcher/reconcile.ml @@ -0,0 +1,228 @@ +open! Base +open! Import +open Expect_test_common +open Sexplib0.Sexp_conv + +module Result = struct + (* Either match with an explicit success, or (lazily) produce a correction. *) + type 'a t = + | Match + | Correction of 'a + [@@deriving_inline sexp_of, compare] + + let _ = fun (_ : 'a t) -> () + + let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = + fun (type a__004_) : ((a__004_ -> Sexplib0.Sexp.t) -> a__004_ t -> Sexplib0.Sexp.t) -> + fun _of_a__001_ -> function + | Match -> Sexplib0.Sexp.Atom "Match" + | Correction arg0__002_ -> + let res0__003_ = _of_a__001_ arg0__002_ in + Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Correction"; res0__003_ ] + ;; + + let _ = sexp_of_t + + let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = + fun _cmp__a a__005_ b__006_ -> + if Stdlib.( == ) a__005_ b__006_ + then 0 + else ( + match a__005_, b__006_ with + | Match, Match -> 0 + | Match, _ -> -1 + | _, Match -> 1 + | Correction _a__007_, Correction _b__008_ -> _cmp__a _a__007_ _b__008_) + ;; + + let _ = compare + + [@@@end] + + let map t ~f = + match t with + | Match -> Match + | Correction x -> Correction (f x) + ;; + + let value t ~success = + match t with + | Match -> success + | Correction f -> f + ;; +end + +let matches_regexp ~(pat : Re.t) s = + Re.execp (Re.compile (Re.whole_string pat)) s +;; + +let glob = Re.Glob.glob ~anchored:true ~pathname:false ~expand_braces:true + +let line_matches ~(expect : Fmt.t) ~actual = + match expect with + | Literal expect -> expect = actual + | Glob expect -> matches_regexp ~pat:(glob expect) actual + | Regexp expect -> matches_regexp ~pat:(Re.Emacs.re expect) actual +;; + +let literal_line ~allow_output_patterns actual : Fmt.t Cst.Line.t = + match actual with + | "" -> Blank "" + | _ -> + let line_matches_itself = + (not allow_output_patterns) + || line_matches + ~expect:(Lexer.parse_pretty_line actual ~allow_output_patterns) + ~actual + in + Not_blank + { data = Literal actual + ; orig = (if line_matches_itself then actual else actual ^ " (literal)") + ; trailing_blanks = "" + } +;; + +let reconcile_line ~(expect : Fmt.t) ~actual ~allow_output_patterns + : Fmt.t Cst.Line.t Result.t + = + assert (not (String.contains actual '\n')); + if line_matches ~expect ~actual + then Match + else Correction (literal_line actual ~allow_output_patterns) +;; + +let rec lines_match + ~(expect_lines : Fmt.t Cst.Line.t list) + ~(actual_lines : string list) + ~allow_output_patterns + : bool + = + match expect_lines, actual_lines with + | [], [] -> true + | [], _ -> false + | _, [] -> false + | expect :: expect_lines, actual :: actual_lines -> + let format = + Cst.Line.data expect ~blank:(Literal "") ~conflict_marker:(fun marker -> + Literal marker) + in + let line = reconcile_line ~expect:format ~actual ~allow_output_patterns in + (match line with + | Match -> lines_match ~expect_lines ~actual_lines ~allow_output_patterns + | Correction _ -> false) +;; + +let rec corrected_rev + acc + ~(expect_lines : Fmt.t Cst.Line.t list) + ~(actual_lines : string list) + ~allow_output_patterns + : Fmt.t Cst.Line.t list + = + match expect_lines, actual_lines with + | [], [] -> acc + | [], actual_lines -> + List.fold actual_lines ~init:acc ~f:(fun acc x -> + literal_line x ~allow_output_patterns :: acc) + | _, [] -> acc + | expect :: expect_lines, actual :: actual_lines -> + let format = + Cst.Line.data expect ~blank:(Literal "") ~conflict_marker:(fun marker -> + Literal marker) + in + let line = + reconcile_line ~expect:format ~actual ~allow_output_patterns + |> Result.value ~success:expect + in + corrected_rev ~expect_lines ~actual_lines (line :: acc) ~allow_output_patterns +;; + +let reconcile_lines ~expect_lines ~actual_lines ~allow_output_patterns + : Fmt.t Cst.Line.t list Result.t + = + if lines_match ~expect_lines ~actual_lines ~allow_output_patterns + then Match + else + Correction + (List.rev (corrected_rev [] ~expect_lines ~actual_lines ~allow_output_patterns)) +;; + +let expectation_body_internal + ~(expect : Fmt.t Cst.t Expectation.Body.t) + ~actual + ~default_indent + ~pad_single_line + ~allow_output_patterns + : Fmt.t Cst.t Expectation.Body.t Result.t + = + match expect with + | Exact expect -> if expect = actual then Match else Correction (Exact actual) + | Output -> Match + | Pretty expect -> + let actual_lines = + Lexer.strip_surrounding_whitespaces actual |> Cst.stripped_original_lines + in + let expect_lines = Cst.to_lines expect in + (match reconcile_lines ~expect_lines ~actual_lines ~allow_output_patterns with + | Match -> Match + | Correction reconciled_lines -> + let reconciled = + Cst.reconcile + expect + ~lines:reconciled_lines + ~default_indentation:default_indent + ~pad_single_line + in + Correction (Pretty reconciled)) + | Unreachable -> + let actual_lines = + Lexer.strip_surrounding_whitespaces actual |> Cst.stripped_original_lines + in + (match reconcile_lines ~expect_lines:[] ~actual_lines ~allow_output_patterns with + | Match -> Correction (Pretty (Empty "")) + | Correction reconciled_lines -> + let reconciled = + Cst.reconcile + (Empty "") + ~lines:reconciled_lines + ~default_indentation:default_indent + ~pad_single_line + in + Correction (Pretty reconciled)) +;; + +let expectation_body + ~(expect : Fmt.t Cst.t Expectation.Body.t) + ~actual + ~default_indent + ~pad_single_line + ~allow_output_patterns + : Fmt.t Cst.t Expectation.Body.t Result.t + = + let res = + expectation_body_internal + ~expect + ~actual + ~default_indent + ~pad_single_line + ~allow_output_patterns + in + match res with + | Match -> Match + | Correction c -> + (match + expectation_body_internal + ~expect:c + ~actual + ~default_indent + ~pad_single_line + ~allow_output_patterns + with + | Match -> res + | Correction _ -> assert false) +;; + +module Private = struct + let line_matches = line_matches + let reconcile_line = reconcile_line +end diff --git a/matcher/reconcile.mli b/matcher/reconcile.mli new file mode 100644 index 0000000..57fb4a8 --- /dev/null +++ b/matcher/reconcile.mli @@ -0,0 +1,48 @@ +(** Determine whether a test's output matches its expected output. *) + +open! Base +open Base.Exported_for_specific_uses (* for [Ppx_compare_lib] *) +open Expect_test_common + +module Result : sig + type 'a t = + | Match + | Correction of 'a + [@@deriving_inline compare, sexp_of] + + include sig + [@@@ocaml.warning "-32"] + + include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + end + [@@ocaml.doc "@inline"] + + [@@@end] + + val map : 'a t -> f:('a -> 'b) -> 'b t +end + +val expectation_body + : expect:Fmt.t Cst.t Expectation.Body.t + -> actual:string + -> default_indent:int + -> pad_single_line:bool + -> allow_output_patterns:bool + -> Fmt.t Cst.t Expectation.Body.t Result.t + +(**/**) + +(*_ See the Jane Street Style Guide for an explanation of [Private] submodules: + + https://opensource.janestreet.com/standards/#private-submodules *) +module Private : sig + val line_matches : expect:Fmt.t -> actual:string -> bool + + val reconcile_line + : expect:Fmt.t + -> actual:string + -> allow_output_patterns:bool + -> Fmt.t Cst.Line.t Result.t +end diff --git a/negative-tests/chdir.ml b/negative-tests/chdir.ml new file mode 100644 index 0000000..b9d4ca0 --- /dev/null +++ b/negative-tests/chdir.ml @@ -0,0 +1,7 @@ +let%expect_test _ = + print_string "About to change dir"; + Sys.mkdir "tmp" 0o755; + Sys.chdir "tmp"; + Sys.rmdir "../tmp"; + [%expect] +;; diff --git a/negative-tests/chdir.ml.corrected.expected b/negative-tests/chdir.ml.corrected.expected new file mode 100644 index 0000000..a54f28e --- /dev/null +++ b/negative-tests/chdir.ml.corrected.expected @@ -0,0 +1,7 @@ +let%expect_test _ = + print_string "About to change dir"; + Sys.mkdir "tmp" 0o755; + Sys.chdir "tmp"; + Sys.rmdir "../tmp"; + [%expect{| About to change dir |}] +;; diff --git a/negative-tests/cinaps/dune b/negative-tests/cinaps/dune new file mode 100644 index 0000000..d8e7fac --- /dev/null +++ b/negative-tests/cinaps/dune @@ -0,0 +1,2 @@ +(library (name expect_test_negative_tests_cinaps) + (libraries base sexp_pretty stdio) (preprocess (pps ppx_jane)))
\ No newline at end of file diff --git a/negative-tests/cinaps/expect_test_negative_tests_cinaps.ml b/negative-tests/cinaps/expect_test_negative_tests_cinaps.ml new file mode 100644 index 0000000..d361f0a --- /dev/null +++ b/negative-tests/cinaps/expect_test_negative_tests_cinaps.ml @@ -0,0 +1,31 @@ +open! Base + +let print_newline () = Stdio.print_endline "" +let print_s sexp = Stdio.print_string (Sexp_pretty.sexp_to_string sexp) + +let generate filenames = + let filenames = List.sort filenames ~compare:String.compare in + let targets = + List.concat + [ List.map filenames ~f:(fun filename -> filename ^ ".corrected") + ; [ "test-output" ] + ] + in + print_newline (); + print_s + [%sexp + `rule + { deps = + [ "./inline_tests_runner"; "./inline_tests_runner.exe"; `glob_files "*.ml" ] + ; targets : string list + ; action = + "rm -f *.ml.corrected 2>/dev/null; ! %{first_dep} -diff-cmd true 2> \ + test-output" + }]; + List.iter targets ~f:(fun target -> + let deps = [ target ^ ".expected"; target ] in + print_newline (); + print_s + [%sexp `alias { name = "runtest"; deps : string list; action = "diff -a %{deps}" }]); + print_newline () +;; diff --git a/negative-tests/cinaps/expect_test_negative_tests_cinaps.mli b/negative-tests/cinaps/expect_test_negative_tests_cinaps.mli new file mode 100644 index 0000000..29a84bc --- /dev/null +++ b/negative-tests/cinaps/expect_test_negative_tests_cinaps.mli @@ -0,0 +1,3 @@ +open! Base + +val generate : string list -> unit diff --git a/negative-tests/disabling/dune b/negative-tests/disabling/dune new file mode 100644 index 0000000..bf3f811 --- /dev/null +++ b/negative-tests/disabling/dune @@ -0,0 +1,4 @@ +(executables (names main) (libraries expect_test_disabling_test_lib) + (preprocess (pps ppx_jane))) + +(alias (name runtest) (deps ./main.exe) (action (bash %{deps})))
\ No newline at end of file diff --git a/negative-tests/disabling/lib/dune b/negative-tests/disabling/lib/dune new file mode 100644 index 0000000..764e708 --- /dev/null +++ b/negative-tests/disabling/lib/dune @@ -0,0 +1 @@ +(library (name expect_test_disabling_test_lib) (preprocess (pps ppx_jane)))
\ No newline at end of file diff --git a/negative-tests/disabling/lib/test_ref.ml b/negative-tests/disabling/lib/test_ref.ml new file mode 100644 index 0000000..f042352 --- /dev/null +++ b/negative-tests/disabling/lib/test_ref.ml @@ -0,0 +1,17 @@ +type t = + | Init + | Set_by_inline_test +[@@deriving sexp, compare] + +let inner = ref Init + +let%expect_test _ = + let module _ = struct + let () = inner := Set_by_inline_test + end + in + () +;; + +let%test_unit _ = inner := Set_by_inline_test +let value () = !inner diff --git a/negative-tests/disabling/lib/test_ref.mli b/negative-tests/disabling/lib/test_ref.mli new file mode 100644 index 0000000..a34a33c --- /dev/null +++ b/negative-tests/disabling/lib/test_ref.mli @@ -0,0 +1,6 @@ +type t = + | Init + | Set_by_inline_test +[@@deriving sexp, compare] + +val value : unit -> t diff --git a/negative-tests/disabling/main.ml b/negative-tests/disabling/main.ml new file mode 100644 index 0000000..fc7491d --- /dev/null +++ b/negative-tests/disabling/main.ml @@ -0,0 +1,3 @@ +open Expect_test_disabling_test_lib + +let () = [%test_result: Test_ref.t] (Test_ref.value ()) ~expect:Init diff --git a/negative-tests/dune b/negative-tests/dune new file mode 100644 index 0000000..795f68c --- /dev/null +++ b/negative-tests/dune @@ -0,0 +1,85 @@ +(library (name expect_test_negative_tests) (libraries core) + (preprocess (pps ppx_jane))) + +(rule + (deps (:first_dep ./inline_tests_runner) ./inline_tests_runner.exe + (glob_files *.ml)) + (targets chdir.ml.corrected exact.ml.corrected exn.ml.corrected + exn_and_trailing.ml.corrected exn_missing.ml.corrected + expect_output.ml.corrected flexible.ml.corrected + function_with_distinct_outputs.ml.corrected functor.ml.corrected + missing.ml.corrected normal_strings.ml.corrected semicolon.ml.corrected + spacing.ml.corrected string_padding.ml.corrected tag.ml.corrected + trailing.ml.corrected unidiomatic_syntax.ml.corrected test-output) + (action + (bash + "rm -f *.ml.corrected 2>/dev/null; ! %{first_dep} -diff-cmd true 2> test-output"))) + +(alias (name runtest) (deps chdir.ml.corrected.expected chdir.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) (deps exact.ml.corrected.expected exact.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) (deps exn.ml.corrected.expected exn.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps exn_and_trailing.ml.corrected.expected exn_and_trailing.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps exn_missing.ml.corrected.expected exn_missing.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps expect_output.ml.corrected.expected expect_output.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps flexible.ml.corrected.expected flexible.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps function_with_distinct_outputs.ml.corrected.expected + function_with_distinct_outputs.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps functor.ml.corrected.expected functor.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps missing.ml.corrected.expected missing.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps normal_strings.ml.corrected.expected normal_strings.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps semicolon.ml.corrected.expected semicolon.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps spacing.ml.corrected.expected spacing.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps string_padding.ml.corrected.expected string_padding.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) (deps tag.ml.corrected.expected tag.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps trailing.ml.corrected.expected trailing.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) + (deps unidiomatic_syntax.ml.corrected.expected + unidiomatic_syntax.ml.corrected) + (action (bash "diff -a %{deps}"))) + +(alias (name runtest) (deps test-output.expected test-output) + (action (bash "diff -a %{deps}")))
\ No newline at end of file diff --git a/negative-tests/exact.ml b/negative-tests/exact.ml new file mode 100644 index 0000000..46e4f79 --- /dev/null +++ b/negative-tests/exact.ml @@ -0,0 +1,23 @@ +open! Core + +(* Check that [%expect_exact] does not strip leading/trailing newlines *) +let%expect_test _ = + print_string "foobarbaz"; + [%expect_exact {| + foobarbaz + |}] +;; + +(* Check that [%expect_exact] does not treat whitespace as indentation *) +let%expect_test _ = + print_string "\nfoobarbaz\n"; + [%expect_exact {| + foobarbaz + |}] +;; + +(* Check that [%expect_exact] does not strip whitespace on single lines *) +let%expect_test _ = + print_string "foobarbaz"; + [%expect_exact {| foobarbaz |}] +;; diff --git a/negative-tests/exact.ml.corrected.expected b/negative-tests/exact.ml.corrected.expected new file mode 100644 index 0000000..523a4f8 --- /dev/null +++ b/negative-tests/exact.ml.corrected.expected @@ -0,0 +1,21 @@ +open! Core + +(* Check that [%expect_exact] does not strip leading/trailing newlines *) +let%expect_test _ = + print_string "foobarbaz"; + [%expect_exact {|foobarbaz|}] +;; + +(* Check that [%expect_exact] does not treat whitespace as indentation *) +let%expect_test _ = + print_string "\nfoobarbaz\n"; + [%expect_exact {| +foobarbaz +|}] +;; + +(* Check that [%expect_exact] does not strip whitespace on single lines *) +let%expect_test _ = + print_string "foobarbaz"; + [%expect_exact {|foobarbaz|}] +;; diff --git a/negative-tests/exit-in-test/broken-test/dune b/negative-tests/exit-in-test/broken-test/dune new file mode 100644 index 0000000..e1ec439 --- /dev/null +++ b/negative-tests/exit-in-test/broken-test/dune @@ -0,0 +1 @@ +(library (name expect_test_call_exit_in_test) (preprocess (pps ppx_jane)))
\ No newline at end of file diff --git a/negative-tests/exit-in-test/broken-test/test.ml b/negative-tests/exit-in-test/broken-test/test.ml new file mode 100644 index 0000000..094eb8e --- /dev/null +++ b/negative-tests/exit-in-test/broken-test/test.ml @@ -0,0 +1,7 @@ +let%expect_test _ = + print_endline "foo"; + [%expect {|foo|}]; + print_endline "Something went horribly wrong, exiting prematurely!"; + (exit 42 : unit); + [%expect {| random output |}] +;; diff --git a/negative-tests/exit-in-test/dune b/negative-tests/exit-in-test/dune new file mode 100644 index 0000000..39eb5d6 --- /dev/null +++ b/negative-tests/exit-in-test/dune @@ -0,0 +1 @@ +(library (name expect_test_test_exit_in_test) (preprocess (pps ppx_jane)))
\ No newline at end of file diff --git a/negative-tests/exit-in-test/test.ml b/negative-tests/exit-in-test/test.ml new file mode 100644 index 0000000..7fd090b --- /dev/null +++ b/negative-tests/exit-in-test/test.ml @@ -0,0 +1,11 @@ +let%expect_test _ = + ignore (Sys.command "./broken-test/inline_tests_runner" : int); + [%expect + {| + File "test.ml", line 1, characters 0-186: + Error: program exited while expect test was running! + Output captured so far: + foo + Something went horribly wrong, exiting prematurely! + |}] +;; diff --git a/negative-tests/exn.ml b/negative-tests/exn.ml new file mode 100644 index 0000000..c5921f1 --- /dev/null +++ b/negative-tests/exn.ml @@ -0,0 +1,8 @@ +open! Core + +let%expect_test _ = + [%expect {| hi ho |}]; + Printexc.record_backtrace false; + ignore (failwith "hi ho" : unit); + [%expect {| it's off to work we go |}] +;; diff --git a/negative-tests/exn.ml.corrected.expected b/negative-tests/exn.ml.corrected.expected new file mode 100644 index 0000000..804c21c --- /dev/null +++ b/negative-tests/exn.ml.corrected.expected @@ -0,0 +1,9 @@ +open! Core + +let%expect_test _ = + [%expect {| |}]; + Printexc.record_backtrace false; + ignore (failwith "hi ho" : unit); + [%expect.unreachable] +[@@expect.uncaught_exn {| (Failure "hi ho") |}] +;; diff --git a/negative-tests/exn_and_trailing.ml b/negative-tests/exn_and_trailing.ml new file mode 100644 index 0000000..5d01d6a --- /dev/null +++ b/negative-tests/exn_and_trailing.ml @@ -0,0 +1,6 @@ +let%expect_test _ = + print_endline "hello"; + if true then raise Exit; + [%expect {| hello |}] +[@@expect.uncaught_exn {| Exit |}] +;; diff --git a/negative-tests/exn_and_trailing.ml.corrected.expected b/negative-tests/exn_and_trailing.ml.corrected.expected new file mode 100644 index 0000000..9e79235 --- /dev/null +++ b/negative-tests/exn_and_trailing.ml.corrected.expected @@ -0,0 +1,10 @@ +let%expect_test _ = + print_endline "hello"; + if true then raise Exit; + [%expect.unreachable] +[@@expect.uncaught_exn {| + Exit + Trailing output + --------------- + hello |}] +;; diff --git a/negative-tests/exn_missing.ml b/negative-tests/exn_missing.ml new file mode 100644 index 0000000..96d033e --- /dev/null +++ b/negative-tests/exn_missing.ml @@ -0,0 +1,12 @@ +open! Core + +let%expect_test "without trailing output" = + printf "hello world"; + [%expect "hello world"] +[@@expect.uncaught_exn {| (Failure "hi ho") |}] +;; + +let%expect_test "with trailing output" = + printf "hello world" +[@@expect.uncaught_exn {| (Failure "hi ho") |}] +;; diff --git a/negative-tests/exn_missing.ml.corrected.expected b/negative-tests/exn_missing.ml.corrected.expected new file mode 100644 index 0000000..5f2b487 --- /dev/null +++ b/negative-tests/exn_missing.ml.corrected.expected @@ -0,0 +1,11 @@ +open! Core + +let%expect_test "without trailing output" = + printf "hello world"; + [%expect "hello world"] +;; + +let%expect_test "with trailing output" = + printf "hello world"; + [%expect {| hello world |}] +;; diff --git a/negative-tests/expect_output.ml b/negative-tests/expect_output.ml new file mode 100644 index 0000000..5910106 --- /dev/null +++ b/negative-tests/expect_output.ml @@ -0,0 +1,9 @@ +open! Core + +let%expect_test _ = + if false + then ( + print_string "hello"; + print_string [%expect.output]; + [%expect {||}]) +;; diff --git a/negative-tests/expect_output.ml.corrected.expected b/negative-tests/expect_output.ml.corrected.expected new file mode 100644 index 0000000..7684e43 --- /dev/null +++ b/negative-tests/expect_output.ml.corrected.expected @@ -0,0 +1,9 @@ +open! Core + +let%expect_test _ = + if false + then ( + print_string "hello"; + print_string [%expect.output]; + [%expect.unreachable]) +;; diff --git a/negative-tests/export_test.ml b/negative-tests/export_test.ml new file mode 100644 index 0000000..9460340 --- /dev/null +++ b/negative-tests/export_test.ml @@ -0,0 +1,3 @@ +module M () = struct + let%expect_test _ = () +end diff --git a/negative-tests/flexible.ml b/negative-tests/flexible.ml new file mode 100644 index 0000000..14f62c6 --- /dev/null +++ b/negative-tests/flexible.ml @@ -0,0 +1,117 @@ +open! Core + +(* The generated expectation should follow user formatting when present, otherwise it + should follow a sensible default *) + +(* Single line actual.. *) + +let%expect_test _ = + print_string "hello"; + [%expect {||}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| WRONG + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| WRONG + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + WRONG |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + WRONG + |}] +;; + +(* Multi line actual... *) + +let%expect_test _ = + print_string "one1\ntwo"; + [%expect {||}] +;; + +let%expect_test _ = + print_string "one2\ntwo"; + [%expect {| + |}] +;; + +let%expect_test _ = + print_string "one3\ntwo"; + [%expect {| + |}] +;; + +let%expect_test _ = + print_string "one4\ntwo"; + [%expect {| WRONG + |}] +;; + +let%expect_test _ = + print_string "one5\ntwo"; + [%expect {| + WRONG |}] +;; + +let%expect_test _ = + print_string "one6\ntwo"; + [%expect {| + WRONG + |}] +;; + +let%expect_test _ = + print_string "one8\ntwo"; + [%expect {| + WRONG + THING |}] +;; + +let%expect_test _ = + print_string "one9\ntwo"; + [%expect {| + WRONG + THING + |}] +;; + +let%expect_test _ = + print_string "one10\ntwo"; + [%expect {| + WRONG + THING + |}] +;; + +let%expect_test _ = + print_string "one11\ntwo"; + [%expect {| + WRONG + THING + |}] +;; diff --git a/negative-tests/flexible.ml.corrected.expected b/negative-tests/flexible.ml.corrected.expected new file mode 100644 index 0000000..7b145d4 --- /dev/null +++ b/negative-tests/flexible.ml.corrected.expected @@ -0,0 +1,125 @@ +open! Core + +(* The generated expectation should follow user formatting when present, otherwise it + should follow a sensible default *) + +(* Single line actual.. *) + +let%expect_test _ = + print_string "hello"; + [%expect {| hello |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| hello |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| hello |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| hello + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| hello + |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + hello |}] +;; + +let%expect_test _ = + print_string "hello"; + [%expect {| + hello + |}] +;; + +(* Multi line actual... *) + +let%expect_test _ = + print_string "one1\ntwo"; + [%expect {| + one1 + two |}] +;; + +let%expect_test _ = + print_string "one2\ntwo"; + [%expect {| + one2 + two + |}] +;; + +let%expect_test _ = + print_string "one3\ntwo"; + [%expect {| + one3 + two + |}] +;; + +let%expect_test _ = + print_string "one4\ntwo"; + [%expect {| + one4 + two + |}] +;; + +let%expect_test _ = + print_string "one5\ntwo"; + [%expect {| + one5 + two |}] +;; + +let%expect_test _ = + print_string "one6\ntwo"; + [%expect {| + one6 + two + |}] +;; + +let%expect_test _ = + print_string "one8\ntwo"; + [%expect {| + one8 + two |}] +;; + +let%expect_test _ = + print_string "one9\ntwo"; + [%expect {| + one9 + two + |}] +;; + +let%expect_test _ = + print_string "one10\ntwo"; + [%expect {| + one10 + two + |}] +;; + +let%expect_test _ = + print_string "one11\ntwo"; + [%expect {| + one11 + two + |}] +;; diff --git a/negative-tests/function_with_distinct_outputs.ml b/negative-tests/function_with_distinct_outputs.ml new file mode 100644 index 0000000..536d313 --- /dev/null +++ b/negative-tests/function_with_distinct_outputs.ml @@ -0,0 +1,14 @@ +module Expect_test_config = struct + include Expect_test_config + + let upon_unreleasable_issue = `Warning_for_collector_testing +end + +let%expect_test _ = + let f output = + print_string output; + [%expect {| hello world |}] + in + f "foo"; + f "bar" +;; diff --git a/negative-tests/function_with_distinct_outputs.ml.corrected.expected b/negative-tests/function_with_distinct_outputs.ml.corrected.expected new file mode 100644 index 0000000..3806df8 --- /dev/null +++ b/negative-tests/function_with_distinct_outputs.ml.corrected.expected @@ -0,0 +1,19 @@ +module Expect_test_config = struct + include Expect_test_config + + let upon_unreleasable_issue = `Warning_for_collector_testing +end + +let%expect_test _ = + let f output = + print_string output; + [%expect {| + (* expect_test: Collector ran multiple times with different outputs *) + ====================================================================== + foo + ====================================================================== + bar |}] + in + f "foo"; + f "bar" +;; diff --git a/negative-tests/functor.ml b/negative-tests/functor.ml new file mode 100644 index 0000000..97ddbe5 --- /dev/null +++ b/negative-tests/functor.ml @@ -0,0 +1,23 @@ +module Expect_test_config = struct + include Expect_test_config + + let upon_unreleasable_issue = `Warning_for_collector_testing +end + +module M (S : sig + val output : string + end) = +struct + let%expect_test _ = + print_string S.output; + [%expect {| hello world |}] + ;; +end + +module A = M (struct + let output = "foo" + end) + +module B = M (struct + let output = "bar" + end) diff --git a/negative-tests/functor.ml.corrected.expected b/negative-tests/functor.ml.corrected.expected new file mode 100644 index 0000000..778be08 --- /dev/null +++ b/negative-tests/functor.ml.corrected.expected @@ -0,0 +1,28 @@ +module Expect_test_config = struct + include Expect_test_config + + let upon_unreleasable_issue = `Warning_for_collector_testing +end + +module M (S : sig + val output : string + end) = +struct + let%expect_test _ = + print_string S.output; + [%expect {| + (* expect_test: Collector ran multiple times with different outputs *) + ====================================================================== + foo + ====================================================================== + bar |}] + ;; +end + +module A = M (struct + let output = "foo" + end) + +module B = M (struct + let output = "bar" + end) diff --git a/negative-tests/import_test.ml b/negative-tests/import_test.ml new file mode 100644 index 0000000..3bd6340 --- /dev/null +++ b/negative-tests/import_test.ml @@ -0,0 +1,3 @@ +let () = Printexc.record_backtrace false + +include Export_test.M () diff --git a/negative-tests/missing.ml b/negative-tests/missing.ml new file mode 100644 index 0000000..baf6100 --- /dev/null +++ b/negative-tests/missing.ml @@ -0,0 +1,8 @@ +open! Core + +(* Example with no [%expect] node at all *) + +let%expect_test _ = + print_string "hello\n"; + print_string "goodbye\n" +;; diff --git a/negative-tests/missing.ml.corrected.expected b/negative-tests/missing.ml.corrected.expected new file mode 100644 index 0000000..3b3549f --- /dev/null +++ b/negative-tests/missing.ml.corrected.expected @@ -0,0 +1,11 @@ +open! Core + +(* Example with no [%expect] node at all *) + +let%expect_test _ = + print_string "hello\n"; + print_string "goodbye\n"; + [%expect {| + hello + goodbye |}] +;; diff --git a/negative-tests/normal_strings.ml b/negative-tests/normal_strings.ml new file mode 100644 index 0000000..4030de2 --- /dev/null +++ b/negative-tests/normal_strings.ml @@ -0,0 +1,4 @@ +let%expect_test _ = + print_string "foo\nbar\n"; + [%expect ""] +;; diff --git a/negative-tests/normal_strings.ml.corrected.expected b/negative-tests/normal_strings.ml.corrected.expected new file mode 100644 index 0000000..af9e90f --- /dev/null +++ b/negative-tests/normal_strings.ml.corrected.expected @@ -0,0 +1,6 @@ +let%expect_test _ = + print_string "foo\nbar\n"; + [%expect " + foo + bar"] +;; diff --git a/negative-tests/reordered.ml.corrected.expected b/negative-tests/reordered.ml.corrected.expected new file mode 100644 index 0000000..4860204 --- /dev/null +++ b/negative-tests/reordered.ml.corrected.expected @@ -0,0 +1,13 @@ +let f () = + let module M = struct + let () = print_string "bar" + + [%%expect {| bar |}] + end in + () +;; + +print_string "foo"; +[%%expect {| foo |}] + +let () = f () diff --git a/negative-tests/semicolon.ml b/negative-tests/semicolon.ml new file mode 100644 index 0000000..8437239 --- /dev/null +++ b/negative-tests/semicolon.ml @@ -0,0 +1,4 @@ +let%expect_test _ = + print_string "one"; + [%expect {| two |}] +;; diff --git a/negative-tests/semicolon.ml.corrected.expected b/negative-tests/semicolon.ml.corrected.expected new file mode 100644 index 0000000..c11ef22 --- /dev/null +++ b/negative-tests/semicolon.ml.corrected.expected @@ -0,0 +1,4 @@ +let%expect_test _ = + print_string "one"; + [%expect {| one |}] +;; diff --git a/negative-tests/spacing.ml b/negative-tests/spacing.ml new file mode 100644 index 0000000..9ceea0b --- /dev/null +++ b/negative-tests/spacing.ml @@ -0,0 +1,34 @@ +open Core + +let%expect_test _ = + let text_no_final_nl () = print_string "one\ntwo(no newline)\nthree" in + text_no_final_nl (); + [%expect {| + + one + two(no newline) + + three + |}]; + (* take an integer tag to [text] help the different tests be distinguished somewhat in the + .expected.patdiff *) + let text n = Printf.printf "one\ntwo(%d)\nthree\n" n in + text 1; + [%expect {| + one + two(1) + three|}]; + text 2; + [%expect {| + one + two(2) + three + |}]; + (* Check that it reindents expectation properly *) + printf " one\n blah\n three"; + [%expect {| + one + two + three + |}] +;; diff --git a/negative-tests/spacing.ml.corrected.expected b/negative-tests/spacing.ml.corrected.expected new file mode 100644 index 0000000..e0db488 --- /dev/null +++ b/negative-tests/spacing.ml.corrected.expected @@ -0,0 +1,33 @@ +open Core + +let%expect_test _ = + let text_no_final_nl () = print_string "one\ntwo(no newline)\nthree" in + text_no_final_nl (); + [%expect {| + + one + two(no newline) + three + |}]; + (* take an integer tag to [text] help the different tests be distinguished somewhat in the + .expected.patdiff *) + let text n = Printf.printf "one\ntwo(%d)\nthree\n" n in + text 1; + [%expect {| + one + two(1) + three|}]; + text 2; + [%expect {| + one + two(2) + three + |}]; + (* Check that it reindents expectation properly *) + printf " one\n blah\n three"; + [%expect {| + one + blah + three + |}] +;; diff --git a/negative-tests/string_padding.ml b/negative-tests/string_padding.ml new file mode 100644 index 0000000..4ed0867 --- /dev/null +++ b/negative-tests/string_padding.ml @@ -0,0 +1,4 @@ +let%expect_test _ = + print_string "hello"; + [%expect "goodbye"] +;; diff --git a/negative-tests/string_padding.ml.corrected.expected b/negative-tests/string_padding.ml.corrected.expected new file mode 100644 index 0000000..0972474 --- /dev/null +++ b/negative-tests/string_padding.ml.corrected.expected @@ -0,0 +1,4 @@ +let%expect_test _ = + print_string "hello"; + [%expect "hello"] +;; diff --git a/negative-tests/tag.ml b/negative-tests/tag.ml new file mode 100644 index 0000000..827baf6 --- /dev/null +++ b/negative-tests/tag.ml @@ -0,0 +1,19 @@ +open! Core + +let%expect_test _ = + (* Correction should include a string tag *) + print_string "{|String tag required|}"; + [%expect {||}] +;; + +let%expect_test _ = + (* The correction should use the same string-kind (normal,quoted) as the [%expect] *) + print_string "foo\\bar"; + [%expect {||}]; + print_string "hey\\ho"; + [%expect_exact ""]; + print_string {| + Foo + "bar baz"|}; + [%expect.unreachable] +;; diff --git a/negative-tests/tag.ml.corrected.expected b/negative-tests/tag.ml.corrected.expected new file mode 100644 index 0000000..3ad90d1 --- /dev/null +++ b/negative-tests/tag.ml.corrected.expected @@ -0,0 +1,21 @@ +open! Core + +let%expect_test _ = + (* Correction should include a string tag *) + print_string "{|String tag required|}"; + [%expect {xxx| {|String tag required|} |xxx}] +;; + +let%expect_test _ = + (* The correction should use the same string-kind (normal,quoted) as the [%expect] *) + print_string "foo\\bar"; + [%expect {| foo\bar |}]; + print_string "hey\\ho"; + [%expect_exact "hey\\ho"]; + print_string {| + Foo + "bar baz"|}; + [%expect{| + Foo + "bar baz" |}] +;; diff --git a/negative-tests/test-output.expected b/negative-tests/test-output.expected new file mode 100644 index 0000000..630a247 --- /dev/null +++ b/negative-tests/test-output.expected @@ -0,0 +1,8 @@ +File "export_test.ml", line 2, characters 2-24 threw +(Failure + "Trying to run an expect test from the wrong file.\ + \n- test declared at ppx/ppx_expect/negative-tests/export_test.ml:2\ + \n- trying to run it from ppx/ppx_expect/negative-tests/import_test.ml\ + \n"). + +FAILED 1 / 41 tests diff --git a/negative-tests/trailing.ml b/negative-tests/trailing.ml new file mode 100644 index 0000000..10e9f89 --- /dev/null +++ b/negative-tests/trailing.ml @@ -0,0 +1,20 @@ +open! Core + +(* Example with trailing output after last [%expect] node *) + +let%expect_test _ = + print_string "hello"; + [%expect {| hello |}]; + print_string "goodbye\n" +;; + +let%expect_test _ = + print_string "foo"; + [%expect {| foo |}]; + print_string "bar" +;; + +let%expect_test _ = + print_string "hello world"; + [%expect {| hello world |}] +;; diff --git a/negative-tests/trailing.ml.corrected.expected b/negative-tests/trailing.ml.corrected.expected new file mode 100644 index 0000000..b49248b --- /dev/null +++ b/negative-tests/trailing.ml.corrected.expected @@ -0,0 +1,22 @@ +open! Core + +(* Example with trailing output after last [%expect] node *) + +let%expect_test _ = + print_string "hello"; + [%expect {| hello |}]; + print_string "goodbye\n"; + [%expect {| goodbye |}] +;; + +let%expect_test _ = + print_string "foo"; + [%expect {| foo |}]; + print_string "bar"; + [%expect {| bar |}] +;; + +let%expect_test _ = + print_string "hello world"; + [%expect {| hello world |}] +;; diff --git a/negative-tests/unidiomatic_syntax.ml b/negative-tests/unidiomatic_syntax.ml new file mode 100644 index 0000000..6d8596b --- /dev/null +++ b/negative-tests/unidiomatic_syntax.ml @@ -0,0 +1,5 @@ +[%%expect_test + let _ = + Printf.printf "Hello, world.\n"; + [%expect {| Good night, moon. |}]] +;; diff --git a/negative-tests/unidiomatic_syntax.ml.corrected.expected b/negative-tests/unidiomatic_syntax.ml.corrected.expected new file mode 100644 index 0000000..3629983 --- /dev/null +++ b/negative-tests/unidiomatic_syntax.ml.corrected.expected @@ -0,0 +1,5 @@ +[%%expect_test + let _ = + Printf.printf "Hello, world.\n"; + [%expect {| Hello, world. |}]] +;; diff --git a/ppx_expect.opam b/ppx_expect.opam new file mode 100644 index 0000000..7cdcd70 --- /dev/null +++ b/ppx_expect.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +version: "v0.16.0" +maintainer: "Jane Street developers" +authors: ["Jane Street Group, LLC"] +homepage: "https://github.com/janestreet/ppx_expect" +bug-reports: "https://github.com/janestreet/ppx_expect/issues" +dev-repo: "git+https://github.com/janestreet/ppx_expect.git" +doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_expect/index.html" +license: "MIT" +build: [ + ["dune" "build" "-p" name "-j" jobs] +] +depends: [ + "ocaml" {>= "4.14.0"} + "base" {>= "v0.16" & < "v0.17"} + "ppx_here" {>= "v0.16" & < "v0.17"} + "ppx_inline_test" {>= "v0.16" & < "v0.17"} + "stdio" {>= "v0.16" & < "v0.17"} + "dune" {>= "2.0.0"} + "ppxlib" {>= "0.28.0"} + "re" {>= "1.8.0"} +] +available: arch != "arm32" & arch != "x86_32" +synopsis: "Cram like framework for OCaml" +description: " +Part of the Jane Street's PPX rewriters collection. +" diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..f0d3093 --- /dev/null +++ b/src/dune @@ -0,0 +1,7 @@ +(library (name ppx_expect) (public_name ppx_expect) (kind ppx_rewriter) + (ppx_runtime_libraries ppx_expect.collector ppx_expect.config) + (libraries base expect_test_common ppx_expect_payload ppxlib ppx_inline_test + ppx_inline_test.libname ppx_here.expander) + (preprocess (pps ppxlib.metaquot)) + (inline_tests.backend (runner_libraries ppx_expect.evaluator) + (extends ppx_inline_test)))
\ No newline at end of file diff --git a/src/expect_extension.ml b/src/expect_extension.ml new file mode 100644 index 0000000..f924980 --- /dev/null +++ b/src/expect_extension.ml @@ -0,0 +1,48 @@ +open Ppxlib +open Extension + +(* An expect declaration resembles [%%expect {tag|...|tag}]. We allow arbitrary tags so + that users can escape their strings properly if need be. *) +let expect = + Expert.declare + "expect" + Context.expression + (Ppx_expect_payload.pattern ()) + (Ppx_expect_payload.make ~kind:Normal) +;; + +(* An expect extension without pretty formatting *) +let expect_exact = + Expert.declare + "expect_exact" + Context.expression + (Ppx_expect_payload.pattern ()) + (Ppx_expect_payload.make ~kind:Exact) +;; + +let expect_output = + Expert.declare + "@expect.output" + Context.expression + (Ppx_expect_payload.pattern ()) + (Ppx_expect_payload.make ~kind:Output) +;; + +let expect_unreachable = + Expert.declare + "@expect.unreachable" + Context.expression + (Ppx_expect_payload.pattern ()) + (Ppx_expect_payload.make ~kind:Unreachable) +;; + +let expectations = [ expect; expect_exact; expect_output; expect_unreachable ] + +let match_expectation e = + match e.pexp_desc with + | Pexp_extension extension -> + (match Expert.convert expectations ~loc:e.pexp_loc extension with + | None -> None + | Some f -> Some (f ~extension_id_loc:(fst extension).loc)) + | _ -> None +;; diff --git a/src/expect_extension.mli b/src/expect_extension.mli new file mode 100644 index 0000000..be2f0b7 --- /dev/null +++ b/src/expect_extension.mli @@ -0,0 +1,4 @@ +open Ppxlib +open Expect_test_common + +val match_expectation : expression -> Expectation.Raw.t option diff --git a/src/main.ml b/src/main.ml new file mode 100644 index 0000000..95e2753 --- /dev/null +++ b/src/main.ml @@ -0,0 +1,217 @@ +open Expect_test_common +open Base +open Ppxlib +open Ast_builder.Default + +let lift_location + ~loc + ({ filename; line_number; line_start; start_pos; end_pos } : File.Location.t) + = + Merlin_helpers.hide_expression + [%expr + ({ filename = + Expect_test_common.File.Name.of_string + [%e estring ~loc (File.Name.to_string filename)] + ; line_number = [%e eint ~loc line_number] + ; line_start = [%e eint ~loc line_start] + ; start_pos = [%e eint ~loc start_pos] + ; end_pos = [%e eint ~loc end_pos] + } + : Expect_test_common.File.Location.t)] +;; + +let eoption ~loc x = + match x with + | None -> pexp_construct ~loc (Located.mk ~loc (lident "None")) None + | Some e -> pexp_construct ~loc (Located.mk ~loc (lident "Some")) (Some e) +;; + +let estring_option ~loc x = eoption ~loc (Option.map x ~f:(estring ~loc)) + +let lift_expectation ~loc ({ tag; body; extid_location; body_location } : _ Expectation.t) + = + Merlin_helpers.hide_expression + [%expr + ({ tag = [%e estring_option ~loc tag] + ; body = + [%e + match body with + | Exact string -> [%expr Exact [%e estring ~loc string]] + | Output -> [%expr Output] + | Pretty string -> [%expr Pretty [%e estring ~loc string]] + | Unreachable -> [%expr Unreachable]] + ; extid_location = [%e lift_location ~loc extid_location] + ; body_location = [%e lift_location ~loc body_location] + } + : string Expect_test_common.Expectation.t)] +;; + +(* Grab a list of all the output expressions *) +let collect_expectations = + object + inherit [(Location.t * Expectation.Raw.t) list] Ast_traverse.fold as super + + method! expression expr acc = + match Expect_extension.match_expectation expr with + | None -> super#expression expr acc + | Some ext -> + assert_no_attributes expr.pexp_attributes; + (expr.pexp_loc, ext) :: acc + end +;; + +let replace_expects = + object + inherit Ast_traverse.map as super + + method! expression ({ pexp_attributes; pexp_loc = loc; _ } as expr) = + match Expect_extension.match_expectation expr with + | None -> super#expression expr + | Some ext -> + let f_var = + match ext.body with + | Exact _ | Pretty _ | Unreachable -> "Expect_test_collector.save_output" + | Output -> "Expect_test_collector.save_and_return_output" + in + let expr = + [%expr [%e evar ~loc f_var] [%e lift_location ~loc ext.extid_location]] + in + { expr with pexp_attributes } + end +;; + +let file_digest = + let cache = Hashtbl.create (module String) ~size:32 in + fun fname -> + Hashtbl.find_or_add cache fname ~default:(fun () -> + Stdlib.Digest.file fname |> Stdlib.Digest.to_hex) +;; + +let rewrite_test_body ~descr ~tags ~uncaught_exn ~called_by_merlin pstr_loc body = + let loc = pstr_loc in + let expectations = + List.map (collect_expectations#expression body []) ~f:(fun (loc, expect_extension) -> + lift_expectation ~loc expect_extension) + |> elist ~loc + in + let uncaught_exn = + Option.map uncaught_exn ~f:(fun (loc, expectation) -> + lift_expectation ~loc expectation) + |> eoption ~loc + in + let body = replace_expects#expression body in + let absolute_filename = + Ppx_here_expander.expand_filename pstr_loc.loc_start.pos_fname + in + let hash = + if called_by_merlin + then Stdlib.Digest.string "" + else file_digest loc.loc_start.pos_fname + in + [%expr + let module Expect_test_collector = Expect_test_collector.Make (Expect_test_config) in + Expect_test_collector.run + ~file_digest:(Expect_test_common.File.Digest.of_string [%e estring ~loc hash]) + ~location:[%e lift_location ~loc (Ppx_expect_payload.transl_loc pstr_loc)] + ~absolute_filename:[%e estring ~loc absolute_filename] + ~description:[%e estring_option ~loc descr] + ~tags:[%e elist ~loc (List.map tags ~f:(estring ~loc))] + ~expectations:[%e expectations] + ~uncaught_exn_expectation:[%e uncaught_exn] + ~inline_test_config:(module Inline_test_config) + (fun () -> [%e body])] +;; + +module P = struct + open Ast_pattern + + let uncaught_exn = + Attribute.declare_with_name_loc + "@expect.uncaught_exn" + Attribute.Context.value_binding + (map1' (Ppx_expect_payload.pattern ()) ~f:(fun loc x -> loc, x)) + (fun ~name_loc (loc, x) -> + loc, Ppx_expect_payload.make x ~kind:Normal ~extension_id_loc:name_loc) + ;; + + let opt_name () = + map (pstring __) ~f:(fun f x -> f (Some x)) ||| map ppat_any ~f:(fun f -> f None) + ;; + + let pattern () = + pstr + (pstr_value + nonrecursive + (Attribute.pattern + uncaught_exn + (value_binding + ~pat: + (map + (Attribute.pattern Ppx_inline_test.tags (opt_name ())) + ~f:(fun f attributes name_opt -> + f + ~name:name_opt + ~tags: + (match attributes with + | None -> [] + | Some x -> x))) + ~expr:__) + ^:: nil) + ^:: nil) + ;; +end + +(* Set to [true] when we see a [%expect_test] extension *) +module Has_tests = + Driver.Create_file_property + (struct + let name = "ppx_expect.has_tests" + end) + (Bool) + +let expect_test = + Extension.V3.declare_inline + "expect_test" + Structure_item + (P.pattern ()) + (fun ~ctxt uncaught_exn ~name ~tags code -> + let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in + let loc = { loc with loc_ghost = true } in + let called_by_merlin = + String.equal (Ppxlib.Expansion_context.Extension.tool_name ctxt) "merlin" + in + Has_tests.set true; + Ppx_inline_test.validate_extension_point_exn + ~name_of_ppx_rewriter:"ppx_expect" + ~loc + ~tags; + rewrite_test_body ~descr:name ~tags ~uncaught_exn ~called_by_merlin loc code + |> Ppx_inline_test.maybe_drop loc) +;; + +let () = + Driver.register_transformation + "expect_test" + ~rules:[ Context_free.Rule.extension expect_test ] + ~enclose_impl:(fun whole_loc -> + match whole_loc, Ppx_inline_test_libname.get () with + | None, _ | _, None -> [], [] + | Some loc, Some _ -> + let loc = { loc with loc_ghost = true } in + let maybe_drop = Ppx_inline_test.maybe_drop in + let absolute_filename = + Ppx_here_expander.expand_filename loc.loc_start.pos_fname + in + let header = + let loc = { loc with loc_end = loc.loc_start } in + maybe_drop + loc + [%expr + Expect_test_collector.Current_file.set + ~absolute_filename:[%e estring ~loc absolute_filename]] + and footer = + let loc = { loc with loc_start = loc.loc_end } in + maybe_drop loc [%expr Expect_test_collector.Current_file.unset ()] + in + header, footer) +;; diff --git a/src/main.mli b/src/main.mli new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/src/main.mli diff --git a/test/bad_test.ml b/test/bad_test.ml new file mode 100644 index 0000000..a7331d5 --- /dev/null +++ b/test/bad_test.ml @@ -0,0 +1,44 @@ +module Expect_test_config = struct + include Expect_test_config + + let upon_unreleasable_issue = `Warning_for_collector_testing +end + +let get_a_trace () = + let rec loop n = + if n < 0 + then Printexc.get_callstack 10, 0 + else ( + let x, y = loop (n - 1) in + x, y + 1) + in + let trace, _ = loop 10 in + trace +;; + +let print_slot trace n = + match Printexc.backtrace_slots trace with + | None -> assert false + | Some slots -> + let slot = slots.(n) in + (match Printexc.Slot.format 0 slot with + | None -> assert false + | Some str -> print_endline str) +;; + +let%expect_test (_ [@tags "no-js"]) = + (* We create a backtrace with 10 identical slots and then only print the 5th slot. + Otherwise flambda and non-flambda compilers create slightly different + backtraces. *) + let trace = get_a_trace () in + print_slot trace 5; + [%expect + {| + (* expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + Raised by primitive operation at Ppx_expect_test__Bad_test.get_a_trace.loop in file "bad_test.ml", line 12, characters 17-29 + |}] +;; + diff --git a/test/bad_test.mli b/test/bad_test.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/bad_test.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..879c739 --- /dev/null +++ b/test/dune @@ -0,0 +1,3 @@ +(library (name ppx_expect_test) (flags :standard -principal) + (libraries expect_test_collector expect_test_matcher) + (preprocess (pps ppx_assert ppx_expect)))
\ No newline at end of file diff --git a/test/no-output-patterns/dune b/test/no-output-patterns/dune new file mode 100644 index 0000000..4479e51 --- /dev/null +++ b/test/no-output-patterns/dune @@ -0,0 +1,2 @@ +(library (name ppx_expect_test_no_output_patterns) + (preprocess (pps ppx_expect)))
\ No newline at end of file diff --git a/test/no-output-patterns/test.ml b/test/no-output-patterns/test.ml new file mode 100644 index 0000000..dfd6989 --- /dev/null +++ b/test/no-output-patterns/test.ml @@ -0,0 +1,4 @@ +let%expect_test _ = + print_endline "toto (regexp)"; + [%expect {| toto (regexp) |}] +;; diff --git a/test/no-output-patterns/test.mli b/test/no-output-patterns/test.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/no-output-patterns/test.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_matcher.ml b/test/test_matcher.ml new file mode 100644 index 0000000..547f25e --- /dev/null +++ b/test/test_matcher.ml @@ -0,0 +1,209 @@ + +open Ppx_compare_lib.Builtin +open Ppx_sexp_conv_lib.Conv +open Expect_test_common +open Expect_test_matcher + +(* [matcher/lexer.mll] checks for escaped newlines. *) +let%test_unit _ = [%test_result: string] (Scanf.unescaped "xx\\n\032yy") ~expect:"xx\n yy" + +let%test_module "Choose_tag" = + (module struct + open Choose_tag + + let test body = [%test_result: string] (choose ~default:"" body) + let%test_unit _ = test "nice text" ~expect:"" + let%test_unit _ = test "with embedded |} somewhere" ~expect:"xxx" + let%test_unit _ = test "with embedded |a} somewhere" ~expect:"" + let%test_unit _ = test "with embedded |xxx} somewhere" ~expect:"" + let%test_unit _ = test "double - |} and |xxx} - embedding" ~expect:"xxxx" + let testD body = [%test_result: string] (choose ~default:"default" body) + let%test_unit _ = testD "nice text" ~expect:"default" + let%test_unit _ = testD "with embedded |} somewhere" ~expect:"default" + let%test_unit _ = testD "with embedded |default} somewhere" ~expect:"default_xxx" + let%test_unit _ = testD "double - |default} and |default_xxx}" ~expect:"default_xxxx" + end) +;; + +let%test_module "Reconcile" = + (module struct + open Reconcile + open Private + + let%test _ = line_matches ~expect:(Literal "foo") ~actual:"foo" + let%test _ = line_matches ~expect:(Literal "f.*o (regexp)") ~actual:"f.*o (regexp)" + let%test _ = line_matches ~expect:(Regexp "f.*o") ~actual:"foo" + let%test _ = not (line_matches ~expect:(Regexp "f.*o") ~actual:"foo (regexp)") + let%test _ = not (line_matches ~expect:(Regexp "[a]") ~actual:"[a]") + let%test _ = line_matches ~expect:(Regexp "f.*o") ~actual:"foo" + + (* Regexp provides the possibility to match trailing *) + let%test _ = line_matches ~expect:(Regexp "f.*o[ ]") ~actual:"foo " + + let%expect_test _ = + let expect = + Lexer.parse_body + ~allow_output_patterns:false + (Pretty "a\n||||||| conflict-marker\nb\n") + in + (match + expectation_body + ~expect + ~actual:"a\n\nb\n" + ~default_indent:0 + ~pad_single_line:false + ~allow_output_patterns:false + with + | Match -> print_endline "Match" + | Correction correction -> + print_endline "Correction"; + print_endline + (Ppx_sexp_conv_lib.Sexp.to_string_hum + (Expectation.Body.sexp_of_t (Cst.sexp_of_t Fmt.sexp_of_t) correction))); + [%expect + {| + Correction + (Pretty + (Multi_lines + ((leading_spaces "") (trailing_spaces "\n") (indentation "") + (lines + ((Not_blank ((trailing_blanks "") (orig a) (data (Literal a)))) + (Blank "") + (Not_blank ((trailing_blanks "") (orig b) (data (Literal b))))))))) |}] + ;; + + let%test_module _ = + (module struct + let allow_output_patterns = true + + let expect_match ~expect ~actual = + let expect = Lexer.parse_pretty_line expect ~allow_output_patterns in + [%test_result: Fmt.t Cst.Line.t Result.t] + (reconcile_line ~expect ~actual ~allow_output_patterns) + ~expect:Match + ;; + + let expect_correction ~expect ~actual ~corrected = + let expect = Lexer.parse_pretty_line expect ~allow_output_patterns in + let corrected : Fmt.t Cst.Line.t = + Not_blank + { orig = corrected + ; data = Lexer.parse_pretty_line corrected ~allow_output_patterns + ; trailing_blanks = "" + } + in + [%test_result: Fmt.t Cst.Line.t Result.t] + (reconcile_line ~expect ~actual ~allow_output_patterns) + ~expect:(Correction corrected) + ;; + + let%test_unit _ = expect_match ~expect:"foo" ~actual:"foo" + let%test_unit _ = expect_match ~expect:"[a] (regexp)" ~actual:"a" + + let%test_unit _ = + expect_correction ~expect:"[a] (regexp)" ~actual:"b" ~corrected:"b" + ;; + end) + ;; + + let%test_module _ = + (module struct + let allow_output_patterns = true + let strip s = Lexer.strip_surrounding_whitespaces s + + let nb orig trailing_blanks = + Cst.Line.Not_blank { orig; trailing_blanks; data = () } + ;; + + let%test_unit _ = [%test_result: unit Cst.t] (strip "\n ") ~expect:(Empty "\n ") + + let%test_unit _ = + [%test_result: unit Cst.t] + (strip " \n foo \n bar \n plop \n \n blah \n \n ") + ~expect: + (Multi_lines + { leading_spaces = " \n" + ; trailing_spaces = "\n \n " + ; indentation = " " + ; lines = + [ nb "foo" " " + ; nb " bar" " " + ; nb " plop" " " + ; Blank " " + ; nb " blah" " " + ] + }) + ;; + + let%test_unit _ = + [%test_result: unit Cst.t] + (strip "abc \ndef ") + ~expect: + (Multi_lines + { leading_spaces = "" + ; trailing_spaces = " " + ; indentation = "" + ; lines = [ nb "abc" " "; nb "def" "" ] + }) + ;; + + let%test_unit _ = + [%test_result: unit Cst.t] + (strip " [a] (regexp) ") + ~expect: + (Single_line + { leading_blanks = " " + ; trailing_spaces = " " + ; orig = "[a] (regexp)" + ; data = () + }) + ;; + + let expect_match ~expect ~actual = + let expect = Lexer.parse_body (Pretty expect) ~allow_output_patterns in + [%test_result: Fmt.t Cst.t Expectation.Body.t Result.t] + (expectation_body + ~expect + ~actual + ~default_indent:0 + ~pad_single_line:true + ~allow_output_patterns) + ~expect:Match + ;; + + let expect_correction ~expect ~actual ~default_indent ~corrected = + let expect = Lexer.parse_body (Pretty expect) ~allow_output_patterns in + [%test_result: Fmt.t Cst.t Expectation.Body.t Result.t] + (expectation_body + ~expect + ~actual + ~default_indent + ~pad_single_line:true + ~allow_output_patterns) + ~expect:(Correction corrected) + ;; + + let%test_unit _ = expect_match ~expect:" foo " ~actual:"foo" + let%test_unit _ = expect_match ~expect:"foo\n[a] (regexp)" ~actual:"foo\na" + + let%test_unit _ = + expect_correction + ~expect:"foo\n[a] (regexp)" + ~actual:"foo\nb" + ~default_indent:0 + ~corrected:(Lexer.parse_body ~allow_output_patterns:true (Pretty "foo\nb")) + ;; + + (* check regexp are preserved in corrections *) + let%test_unit _ = + expect_correction + ~expect:"foo\n[ab]* (regexp)" + ~actual:"not-foo\nbaba" + ~default_indent:0 + ~corrected: + (Lexer.parse_body ~allow_output_patterns (Pretty "not-foo\n[ab]* (regexp)")) + ;; + end) + ;; + end) +;; diff --git a/test/test_matcher.mli b/test/test_matcher.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_matcher.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_output.ml b/test/test_output.ml new file mode 100644 index 0000000..29a4495 --- /dev/null +++ b/test/test_output.ml @@ -0,0 +1,23 @@ +let%expect_test "expect.output" = + Printf.printf "hello\n"; + let output = [%expect.output] in + Printf.printf "'%s'\n" (String.uppercase_ascii output); + [%expect {| + 'HELLO + ' |}]; + Printf.printf "string without line break"; + let output = [%expect.output] in + Printf.printf "%s\n" (String.uppercase_ascii output); + [%expect {| STRING WITHOUT LINE BREAK |}] +;; + +let%expect_test "Ensure repeated expect.outputs clean up in-betweeen" = + Printf.printf "first"; + let output1 = [%expect.output] in + Printf.printf "second"; + let output2 = [%expect.output] in + Printf.printf "%s" (String.uppercase_ascii output2); + [%expect {| SECOND |}]; + Printf.printf "%s" (String.uppercase_ascii output1); + [%expect {| FIRST |}] +;; diff --git a/test/test_output.mli b/test/test_output.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_output.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml new file mode 100644 index 0000000..8b5c9c4 --- /dev/null +++ b/test/test_sanitize.ml @@ -0,0 +1,30 @@ +let%expect_test "no sanitization" = + print_endline "hi!"; + [%expect {| hi! |}] +;; + +let%test_module _ = + (module struct + module Expect_test_config = struct + include Expect_test_config + + let sanitize s = if s = "" then "" else "local module sanitize: " ^ s + end + + let%expect_test "local sanitize" = + print_endline "hi!"; + [%expect {| local module sanitize: hi! |}] + ;; + end) +;; + +module Expect_test_config = struct + include Expect_test_config + + let sanitize s = if s = "" then "" else "SANITIZED: " ^ s +end + +let%expect_test "sanitize" = + print_endline "hi!"; + [%expect {| SANITIZED: hi! |}] +;; diff --git a/test/test_sanitize.mli b/test/test_sanitize.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_sanitize.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_stderr.ml b/test/test_stderr.ml new file mode 100644 index 0000000..13b2273 --- /dev/null +++ b/test/test_stderr.ml @@ -0,0 +1,4 @@ +let%expect_test "stderr is collected" = + Printf.eprintf "hello\n"; + [%expect {| hello |}] +;; diff --git a/test/test_stderr.mli b/test/test_stderr.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/test_stderr.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/uncaught_exn.ml b/test/uncaught_exn.ml new file mode 100644 index 0000000..99bddd9 --- /dev/null +++ b/test/uncaught_exn.ml @@ -0,0 +1,14 @@ +let%expect_test _ = + Printexc.record_backtrace false; + assert false +[@@expect.uncaught_exn {| + "Assert_failure uncaught_exn.ml:3:2" |}] +;; + +let%expect_test "Expectation with uncaught expectation" = + Printexc.record_backtrace false; + ignore (assert false); + [%expect.unreachable] +[@@expect.uncaught_exn {| + "Assert_failure uncaught_exn.ml:10:9" |}] +;; diff --git a/test/uncaught_exn.mli b/test/uncaught_exn.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/uncaught_exn.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/unidiomatic_syntax.ml b/test/unidiomatic_syntax.ml new file mode 100644 index 0000000..3629983 --- /dev/null +++ b/test/unidiomatic_syntax.ml @@ -0,0 +1,5 @@ +[%%expect_test + let _ = + Printf.printf "Hello, world.\n"; + [%expect {| Hello, world. |}]] +;; diff --git a/test/unidiomatic_syntax.mli b/test/unidiomatic_syntax.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/unidiomatic_syntax.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/unreachable.ml b/test/unreachable.ml new file mode 100644 index 0000000..55490f6 --- /dev/null +++ b/test/unreachable.ml @@ -0,0 +1 @@ +let%expect_test _ = if false then [%expect.unreachable] diff --git a/test/unreachable.mli b/test/unreachable.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/unreachable.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) |