pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=a53965983e077584aa1e80b16d9406d1511c6d4d ppx_expect-0.16.0/000077500000000000000000000000001442175067100137645ustar00rootroot00000000000000ppx_expect-0.16.0/.gitignore000066400000000000000000000000411442175067100157470ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_expect-0.16.0/CHANGES.md000066400000000000000000000127671442175067100153730ustar00rootroot00000000000000## 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. ppx_expect-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100162140ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_expect-0.16.0/LICENSE.md000066400000000000000000000021461442175067100153730ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_expect-0.16.0/Makefile000066400000000000000000000004031442175067100154210ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_expect-0.16.0/README.org000066400000000000000000000212761442175067100154420ustar00rootroot00000000000000#+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. ppx_expect-0.16.0/collector/000077500000000000000000000000001442175067100157525ustar00rootroot00000000000000ppx_expect-0.16.0/collector/check_backtraces.mli000066400000000000000000000000511442175067100217100ustar00rootroot00000000000000val contains_backtraces : string -> bool ppx_expect-0.16.0/collector/check_backtraces.mll000066400000000000000000000005251442175067100217210ustar00rootroot00000000000000let 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) } ppx_expect-0.16.0/collector/dune000066400000000000000000000005341442175067100166320ustar00rootroot00000000000000(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)ppx_expect-0.16.0/collector/expect_test_collector.ml000066400000000000000000000205431442175067100227050ustar00rootroot00000000000000open 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 ;; ppx_expect-0.16.0/collector/expect_test_collector.mli000066400000000000000000000034441442175067100230570ustar00rootroot00000000000000open 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 ppx_expect-0.16.0/collector/expect_test_collector_stubs.c000066400000000000000000000065401442175067100237400ustar00rootroot00000000000000#include #include #include #include #ifndef _MSC_VER #include #endif /* #include */ /* 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 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); } ppx_expect-0.16.0/collector/runtime.js000066400000000000000000000023451442175067100177770ustar00rootroot00000000000000//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 } ppx_expect-0.16.0/common/000077500000000000000000000000001442175067100152545ustar00rootroot00000000000000ppx_expect-0.16.0/common/dune000066400000000000000000000003461442175067100161350ustar00rootroot00000000000000(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)))ppx_expect-0.16.0/common/expect_test_common.ml000066400000000000000000000002671442175067100215120ustar00rootroot00000000000000module Std = struct module File = File module Expectation = Expectation end [@@deprecated "[since 2020-03] use [Expect_test_common] instead"] include Std [@@alert "-deprecated"] ppx_expect-0.16.0/common/expectation.ml000066400000000000000000000117261442175067100201400ustar00rootroot00000000000000open! 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 } ppx_expect-0.16.0/common/expectation.mli000066400000000000000000000027501442175067100203060ustar00rootroot00000000000000open! 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 ppx_expect-0.16.0/common/file.ml000066400000000000000000000147171442175067100165370ustar00rootroot00000000000000open! 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 ppx_expect-0.16.0/common/file.mli000066400000000000000000000025411442175067100167000ustar00rootroot00000000000000open! 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 ppx_expect-0.16.0/common/import.ml000066400000000000000000000001111442175067100171110ustar00rootroot00000000000000module Ppx_compare_lib = Base.Exported_for_specific_uses.Ppx_compare_lib ppx_expect-0.16.0/config/000077500000000000000000000000001442175067100152315ustar00rootroot00000000000000ppx_expect-0.16.0/config/dune000066400000000000000000000003021442175067100161020ustar00rootroot00000000000000(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))ppx_expect-0.16.0/config/expect_test_config.ml000066400000000000000000000002031442175067100214320ustar00rootroot00000000000000module IO = struct type 'a t = 'a let return x = x end let sanitize s = s let run f = f () let upon_unreleasable_issue = `CR ppx_expect-0.16.0/config/expect_test_config.mli000066400000000000000000000000721442175067100216070ustar00rootroot00000000000000include Expect_test_config_types.S with type 'a IO.t = 'a ppx_expect-0.16.0/config/types/000077500000000000000000000000001442175067100163755ustar00rootroot00000000000000ppx_expect-0.16.0/config/types/dune000066400000000000000000000002661442175067100172570ustar00rootroot00000000000000(library (name expect_test_config_types) (public_name ppx_expect.config_types) (synopsis "Runtime configuration options for ppx_expect") (libraries) (preprocess no_preprocessing))ppx_expect-0.16.0/config/types/expect_test_config_types.ml000066400000000000000000000012731442175067100240320ustar00rootroot00000000000000module 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 ppx_expect-0.16.0/config/types/expect_test_config_types.mli000066400000000000000000000000771442175067100242040ustar00rootroot00000000000000include Expect_test_config_types_intf.Expect_test_config_types ppx_expect-0.16.0/config/types/expect_test_config_types_intf.ml000066400000000000000000000030121442175067100250430ustar00rootroot00000000000000module 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 ppx_expect-0.16.0/dune000066400000000000000000000000001442175067100146300ustar00rootroot00000000000000ppx_expect-0.16.0/dune-project000066400000000000000000000000201442175067100162760ustar00rootroot00000000000000(lang dune 1.10)ppx_expect-0.16.0/evaluator/000077500000000000000000000000001442175067100157665ustar00rootroot00000000000000ppx_expect-0.16.0/evaluator/dune000066400000000000000000000003751442175067100166510ustar00rootroot00000000000000(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))ppx_expect-0.16.0/evaluator/ppx_expect_evaluator.ml000066400000000000000000000210501442175067100225570ustar00rootroot00000000000000open 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) ;; ppx_expect-0.16.0/evaluator/ppx_expect_evaluator.mli000066400000000000000000000000141442175067100227250ustar00rootroot00000000000000(* empty *) ppx_expect-0.16.0/example/000077500000000000000000000000001442175067100154175ustar00rootroot00000000000000ppx_expect-0.16.0/example/chdir.ml000066400000000000000000000003001442175067100170330ustar00rootroot00000000000000(* 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 |}] ;; ppx_expect-0.16.0/example/chdir.mli000066400000000000000000000000551442175067100172130ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/control_chars.ml000066400000000000000000000020211442175067100206040ustar00rootroot00000000000000open Core (* This test contains control chars literally in the ML source. Keep this test separate from other tests in [tests.ml] because the control chars seem to provoke odd behaviour when running commands like [hg diff] *) let%expect_test _ = let chars0_to_32 () = let s = List.range 0 32 |> List.map ~f:(fun i -> String.of_char (Char.of_int_exn i)) (* We use a [sep] to avoid having a trailing tab char in the expected output, which would be hard to write below, because our editors trim trailing whitespace. *) |> String.concat ~sep:"x" in print_string s in chars0_to_32 (); [%expect_exact "\000x\001x\002x\003x\004x\005x\006x\007x\008x\009x\010x\011x\012x\013x\014x\015x\016x\017x\018x\019x\020x\021x\022x\023x\024x\025x\026x\027x\028x\029x\030x\031"]; chars0_to_32 (); [%expect_exact "xxxxxxxxx\tx\nx x x xxxxxxxxxxxxxxxxxx"]; chars0_to_32 (); [%expect {| xxxxxxxxx x x x x xxxxxxxxxxxxxxxxxx|}] ;; ppx_expect-0.16.0/example/control_chars.mli000066400000000000000000000000551442175067100207620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/dune000066400000000000000000000004711442175067100162770ustar00rootroot00000000000000(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))ppx_expect-0.16.0/example/flexible_whitespace.ml000066400000000000000000000002071442175067100217560ustar00rootroot00000000000000let%expect_test _ = print_string " Be more"; [%expect {| Be more |}]; print_string "\nflexible\n"; [%expect {| flexible |}] ;; ppx_expect-0.16.0/example/flexible_whitespace.mli000066400000000000000000000000551442175067100221300ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/function.ml000066400000000000000000000003551442175067100176010ustar00rootroot00000000000000let%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 () ;; ppx_expect-0.16.0/example/function.mli000066400000000000000000000000551442175067100177470ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/functor.ml000066400000000000000000000002251442175067100174300ustar00rootroot00000000000000module M () = struct let%expect_test _ = print_string "hello world"; [%expect {| hello world |}] ;; end module A = M () module B = M () ppx_expect-0.16.0/example/hello_async.ml000066400000000000000000000002401442175067100202450ustar00rootroot00000000000000open Core open Async let%expect_test _ = List.iter [ "hello, "; "world"; "!" ] ~f:(fun s -> print_string s); [%expect {| hello, world! |}]; return () ;; ppx_expect-0.16.0/example/hello_async.mli000066400000000000000000000000551442175067100204220ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/nine.ml000066400000000000000000000044371442175067100167120ustar00rootroot00000000000000(* 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 () ;; ppx_expect-0.16.0/example/nine.mli000066400000000000000000000000551442175067100170530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/reordered.ml000066400000000000000000000002151442175067100177220ustar00rootroot00000000000000let%expect_test _ = let f () = print_string "bar"; [%expect {| bar |}] in print_string "foo"; [%expect {| foo |}]; f () ;; ppx_expect-0.16.0/example/reordered.mli000066400000000000000000000000551442175067100200750ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/space_nine.ml000066400000000000000000000025161442175067100200610ustar00rootroot00000000000000(* 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"] ;; ppx_expect-0.16.0/example/space_nine.mli000066400000000000000000000000551442175067100202260ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/tabs.ml.in000066400000000000000000000004621442175067100173110ustar00rootroot00000000000000 (* 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|}] ppx_expect-0.16.0/example/tabs.mli000066400000000000000000000000551442175067100170530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/tests.ml000066400000000000000000000010771442175067100171200ustar00rootroot00000000000000open 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}] ;; ppx_expect-0.16.0/example/tests.mli000066400000000000000000000000551442175067100172640ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/three.ml000066400000000000000000000011321442175067100170550ustar00rootroot00000000000000(* 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 |}] ;; ppx_expect-0.16.0/example/three.mli000066400000000000000000000000551442175067100172310ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/example/xnine.ml000066400000000000000000000024741442175067100171010ustar00rootroot00000000000000(* 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"] ;; ppx_expect-0.16.0/example/xnine.mli000066400000000000000000000000551442175067100172430ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/expect_payload/000077500000000000000000000000001442175067100167655ustar00rootroot00000000000000ppx_expect-0.16.0/expect_payload/dune000066400000000000000000000002111442175067100176350ustar00rootroot00000000000000(library (name ppx_expect_payload) (public_name ppx_expect.payload) (libraries expect_test_common ppxlib) (preprocess no_preprocessing))ppx_expect-0.16.0/expect_payload/ppx_expect_payload.ml000066400000000000000000000051751442175067100232170ustar00rootroot00000000000000open 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)) ;; ppx_expect-0.16.0/expect_payload/ppx_expect_payload.mli000066400000000000000000000007071442175067100233640ustar00rootroot00000000000000open 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 ppx_expect-0.16.0/make-corrected-file/000077500000000000000000000000001442175067100175665ustar00rootroot00000000000000ppx_expect-0.16.0/make-corrected-file/dune000066400000000000000000000002321442175067100204410ustar00rootroot00000000000000(library (name make_corrected_file) (public_name ppx_expect.make_corrected_file) (libraries base ppxlib.print_diff stdio) (preprocess no_preprocessing))ppx_expect-0.16.0/make-corrected-file/import.ml000066400000000000000000000000001442175067100214200ustar00rootroot00000000000000ppx_expect-0.16.0/make-corrected-file/make_corrected_file.ml000066400000000000000000000044271442175067100240750ustar00rootroot00000000000000open! 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.") ;; ppx_expect-0.16.0/make-corrected-file/make_corrected_file.mli000066400000000000000000000016351442175067100242440ustar00rootroot00000000000000open! 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 ppx_expect-0.16.0/matcher/000077500000000000000000000000001442175067100154075ustar00rootroot00000000000000ppx_expect-0.16.0/matcher/choose_tag.ml000066400000000000000000000005511442175067100200550ustar00rootroot00000000000000open 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 ;; ppx_expect-0.16.0/matcher/choose_tag.mli000066400000000000000000000000601442175067100202210ustar00rootroot00000000000000val choose : default:string -> string -> string ppx_expect-0.16.0/matcher/cst.ml000066400000000000000000000464631442175067100165470ustar00rootroot00000000000000open! 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 ;; ppx_expect-0.16.0/matcher/cst.mli000066400000000000000000000137101442175067100167050ustar00rootroot00000000000000(** 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 ppx_expect-0.16.0/matcher/dune000066400000000000000000000004361442175067100162700ustar00rootroot00000000000000(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)ppx_expect-0.16.0/matcher/expect_test_matcher.ml000066400000000000000000000004301442175067100217700ustar00rootroot00000000000000module 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"] ppx_expect-0.16.0/matcher/fmt.ml000066400000000000000000000034021442175067100165260ustar00rootroot00000000000000open! 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] ppx_expect-0.16.0/matcher/fmt.mli000066400000000000000000000007231442175067100167020ustar00rootroot00000000000000(** 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] ppx_expect-0.16.0/matcher/import.ml000066400000000000000000000001111442175067100172440ustar00rootroot00000000000000module Ppx_compare_lib = Base.Exported_for_specific_uses.Ppx_compare_lib ppx_expect-0.16.0/matcher/lexer.mli000066400000000000000000000007441442175067100172360ustar00rootroot00000000000000open 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 ppx_expect-0.16.0/matcher/lexer.mll000066400000000000000000000106561442175067100172440ustar00rootroot00000000000000{ 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) } ppx_expect-0.16.0/matcher/matcher.ml000066400000000000000000000365111442175067100173720ustar00rootroot00000000000000open 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 ;; ppx_expect-0.16.0/matcher/matcher.mli000066400000000000000000000037121442175067100175400ustar00rootroot00000000000000open 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 ppx_expect-0.16.0/matcher/reconcile.ml000066400000000000000000000142721442175067100177120ustar00rootroot00000000000000open! 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 ppx_expect-0.16.0/matcher/reconcile.mli000066400000000000000000000021611442175067100200550ustar00rootroot00000000000000(** 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 ppx_expect-0.16.0/negative-tests/000077500000000000000000000000001442175067100167265ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/chdir.ml000066400000000000000000000002131442175067100203450ustar00rootroot00000000000000let%expect_test _ = print_string "About to change dir"; Sys.mkdir "tmp" 0o755; Sys.chdir "tmp"; Sys.rmdir "../tmp"; [%expect] ;; ppx_expect-0.16.0/negative-tests/chdir.ml.corrected.expected000066400000000000000000000002441442175067100241220ustar00rootroot00000000000000let%expect_test _ = print_string "About to change dir"; Sys.mkdir "tmp" 0o755; Sys.chdir "tmp"; Sys.rmdir "../tmp"; [%expect{| About to change dir |}] ;; ppx_expect-0.16.0/negative-tests/cinaps/000077500000000000000000000000001442175067100202035ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/cinaps/dune000066400000000000000000000001621442175067100210600ustar00rootroot00000000000000(library (name expect_test_negative_tests_cinaps) (libraries base sexp_pretty stdio) (preprocess (pps ppx_jane)))ppx_expect-0.16.0/negative-tests/cinaps/expect_test_negative_tests_cinaps.ml000066400000000000000000000016431442175067100275310ustar00rootroot00000000000000open! 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 () ;; ppx_expect-0.16.0/negative-tests/cinaps/expect_test_negative_tests_cinaps.mli000066400000000000000000000000571442175067100277000ustar00rootroot00000000000000open! Base val generate : string list -> unit ppx_expect-0.16.0/negative-tests/disabling/000077500000000000000000000000001442175067100206625ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/disabling/dune000066400000000000000000000002441442175067100215400ustar00rootroot00000000000000(executables (names main) (libraries expect_test_disabling_test_lib) (preprocess (pps ppx_jane))) (alias (name runtest) (deps ./main.exe) (action (bash %{deps})))ppx_expect-0.16.0/negative-tests/disabling/lib/000077500000000000000000000000001442175067100214305ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/disabling/lib/dune000066400000000000000000000001131442175067100223010ustar00rootroot00000000000000(library (name expect_test_disabling_test_lib) (preprocess (pps ppx_jane)))ppx_expect-0.16.0/negative-tests/disabling/lib/test_ref.ml000066400000000000000000000004101442175067100235700ustar00rootroot00000000000000type 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 ppx_expect-0.16.0/negative-tests/disabling/lib/test_ref.mli000066400000000000000000000001331442175067100237430ustar00rootroot00000000000000type t = | Init | Set_by_inline_test [@@deriving sexp, compare] val value : unit -> t ppx_expect-0.16.0/negative-tests/disabling/main.ml000066400000000000000000000001521442175067100221360ustar00rootroot00000000000000open Expect_test_disabling_test_lib let () = [%test_result: Test_ref.t] (Test_ref.value ()) ~expect:Init ppx_expect-0.16.0/negative-tests/dune000066400000000000000000000056231442175067100176120ustar00rootroot00000000000000(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}")))ppx_expect-0.16.0/negative-tests/exact.ml000066400000000000000000000007721442175067100203720ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/exact.ml.corrected.expected000066400000000000000000000007541442175067100241430ustar00rootroot00000000000000open! 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|}] ;; ppx_expect-0.16.0/negative-tests/exit-in-test/000077500000000000000000000000001442175067100212605ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/exit-in-test/broken-test/000077500000000000000000000000001442175067100235155ustar00rootroot00000000000000ppx_expect-0.16.0/negative-tests/exit-in-test/broken-test/dune000066400000000000000000000001121442175067100243650ustar00rootroot00000000000000(library (name expect_test_call_exit_in_test) (preprocess (pps ppx_jane)))ppx_expect-0.16.0/negative-tests/exit-in-test/broken-test/test.ml000066400000000000000000000002761442175067100250330ustar00rootroot00000000000000let%expect_test _ = print_endline "foo"; [%expect {|foo|}]; print_endline "Something went horribly wrong, exiting prematurely!"; (exit 42 : unit); [%expect {| random output |}] ;; ppx_expect-0.16.0/negative-tests/exit-in-test/dune000066400000000000000000000001121442175067100221300ustar00rootroot00000000000000(library (name expect_test_test_exit_in_test) (preprocess (pps ppx_jane)))ppx_expect-0.16.0/negative-tests/exit-in-test/test.ml000066400000000000000000000004641442175067100225750ustar00rootroot00000000000000let%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! |}] ;; ppx_expect-0.16.0/negative-tests/exn.ml000066400000000000000000000002541442175067100200530ustar00rootroot00000000000000open! Core let%expect_test _ = [%expect {| hi ho |}]; Printexc.record_backtrace false; ignore (failwith "hi ho" : unit); [%expect {| it's off to work we go |}] ;; ppx_expect-0.16.0/negative-tests/exn.ml.corrected.expected000066400000000000000000000003051442175067100236210ustar00rootroot00000000000000open! Core let%expect_test _ = [%expect {| |}]; Printexc.record_backtrace false; ignore (failwith "hi ho" : unit); [%expect.unreachable] [@@expect.uncaught_exn {| (Failure "hi ho") |}] ;; ppx_expect-0.16.0/negative-tests/exn_and_trailing.ml000066400000000000000000000002061442175067100225630ustar00rootroot00000000000000let%expect_test _ = print_endline "hello"; if true then raise Exit; [%expect {| hello |}] [@@expect.uncaught_exn {| Exit |}] ;; ppx_expect-0.16.0/negative-tests/exn_and_trailing.ml.corrected.expected000066400000000000000000000002641442175067100263400ustar00rootroot00000000000000let%expect_test _ = print_endline "hello"; if true then raise Exit; [%expect.unreachable] [@@expect.uncaught_exn {| Exit Trailing output --------------- hello |}] ;; ppx_expect-0.16.0/negative-tests/exn_missing.ml000066400000000000000000000004211442175067100216000ustar00rootroot00000000000000open! 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") |}] ;; ppx_expect-0.16.0/negative-tests/exn_missing.ml.corrected.expected000066400000000000000000000003201442175067100253470ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/expect_output.ml000066400000000000000000000002101442175067100221610ustar00rootroot00000000000000open! Core let%expect_test _ = if false then ( print_string "hello"; print_string [%expect.output]; [%expect {||}]) ;; ppx_expect-0.16.0/negative-tests/expect_output.ml.corrected.expected000066400000000000000000000002171442175067100257410ustar00rootroot00000000000000open! Core let%expect_test _ = if false then ( print_string "hello"; print_string [%expect.output]; [%expect.unreachable]) ;; ppx_expect-0.16.0/negative-tests/export_test.ml000066400000000000000000000000621442175067100216360ustar00rootroot00000000000000module M () = struct let%expect_test _ = () end ppx_expect-0.16.0/negative-tests/flexible.ml000066400000000000000000000030631442175067100210540ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/flexible.ml.corrected.expected000066400000000000000000000031661442175067100246310ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/function_with_distinct_outputs.ml000066400000000000000000000004001442175067100256360ustar00rootroot00000000000000module 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" ;; ppx_expect-0.16.0/negative-tests/function_with_distinct_outputs.ml.corrected.expected000066400000000000000000000007571442175067100314260ustar00rootroot00000000000000module 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" ;; ppx_expect-0.16.0/negative-tests/functor.ml000066400000000000000000000006011442175067100207350ustar00rootroot00000000000000module 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) ppx_expect-0.16.0/negative-tests/functor.ml.corrected.expected000066400000000000000000000011601442175067100245070ustar00rootroot00000000000000module 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) ppx_expect-0.16.0/negative-tests/import_test.ml000066400000000000000000000001031442175067100216230ustar00rootroot00000000000000let () = Printexc.record_backtrace false include Export_test.M () ppx_expect-0.16.0/negative-tests/missing.ml000066400000000000000000000002051442175067100207260ustar00rootroot00000000000000open! Core (* Example with no [%expect] node at all *) let%expect_test _ = print_string "hello\n"; print_string "goodbye\n" ;; ppx_expect-0.16.0/negative-tests/missing.ml.corrected.expected000066400000000000000000000002561442175067100245050ustar00rootroot00000000000000open! Core (* Example with no [%expect] node at all *) let%expect_test _ = print_string "hello\n"; print_string "goodbye\n"; [%expect {| hello goodbye |}] ;; ppx_expect-0.16.0/negative-tests/normal_strings.ml000066400000000000000000000001031442175067100223130ustar00rootroot00000000000000let%expect_test _ = print_string "foo\nbar\n"; [%expect ""] ;; ppx_expect-0.16.0/negative-tests/normal_strings.ml.corrected.expected000066400000000000000000000001231442175067100260660ustar00rootroot00000000000000let%expect_test _ = print_string "foo\nbar\n"; [%expect " foo bar"] ;; ppx_expect-0.16.0/negative-tests/reordered.ml.corrected.expected000066400000000000000000000002471442175067100250070ustar00rootroot00000000000000let f () = let module M = struct let () = print_string "bar" [%%expect {| bar |}] end in () ;; print_string "foo"; [%%expect {| foo |}] let () = f () ppx_expect-0.16.0/negative-tests/semicolon.ml000066400000000000000000000001031442175067100212420ustar00rootroot00000000000000let%expect_test _ = print_string "one"; [%expect {| two |}] ;; ppx_expect-0.16.0/negative-tests/semicolon.ml.corrected.expected000066400000000000000000000001031442175067100250130ustar00rootroot00000000000000let%expect_test _ = print_string "one"; [%expect {| one |}] ;; ppx_expect-0.16.0/negative-tests/spacing.ml000066400000000000000000000011411442175067100207010ustar00rootroot00000000000000open 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 |}] ;; ppx_expect-0.16.0/negative-tests/spacing.ml.corrected.expected000066400000000000000000000011331442175067100244530ustar00rootroot00000000000000open 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 |}] ;; ppx_expect-0.16.0/negative-tests/string_padding.ml000066400000000000000000000001051442175067100222500ustar00rootroot00000000000000let%expect_test _ = print_string "hello"; [%expect "goodbye"] ;; ppx_expect-0.16.0/negative-tests/string_padding.ml.corrected.expected000066400000000000000000000001031442175067100260170ustar00rootroot00000000000000let%expect_test _ = print_string "hello"; [%expect "hello"] ;; ppx_expect-0.16.0/negative-tests/tag.ml000066400000000000000000000006351442175067100200370ustar00rootroot00000000000000open! 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] ;; ppx_expect-0.16.0/negative-tests/tag.ml.corrected.expected000066400000000000000000000007331442175067100236070ustar00rootroot00000000000000open! 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" |}] ;; ppx_expect-0.16.0/negative-tests/test-output.expected000066400000000000000000000004431442175067100227670ustar00rootroot00000000000000File "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 ppx_expect-0.16.0/negative-tests/trailing.ml000066400000000000000000000005331442175067100210720ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/trailing.ml.corrected.expected000066400000000000000000000006151442175067100246440ustar00rootroot00000000000000open! 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 |}] ;; ppx_expect-0.16.0/negative-tests/unidiomatic_syntax.ml000066400000000000000000000001501442175067100231670ustar00rootroot00000000000000[%%expect_test let _ = Printf.printf "Hello, world.\n"; [%expect {| Good night, moon. |}]] ;; ppx_expect-0.16.0/negative-tests/unidiomatic_syntax.ml.corrected.expected000066400000000000000000000001441442175067100267430ustar00rootroot00000000000000[%%expect_test let _ = Printf.printf "Hello, world.\n"; [%expect {| Hello, world. |}]] ;; ppx_expect-0.16.0/ppx_expect.opam000066400000000000000000000016261442175067100170260ustar00rootroot00000000000000opam-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. " ppx_expect-0.16.0/src/000077500000000000000000000000001442175067100145535ustar00rootroot00000000000000ppx_expect-0.16.0/src/dune000066400000000000000000000006031442175067100154300ustar00rootroot00000000000000(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)))ppx_expect-0.16.0/src/expect_extension.ml000066400000000000000000000023021442175067100204660ustar00rootroot00000000000000open 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 ;; ppx_expect-0.16.0/src/expect_extension.mli000066400000000000000000000001441442175067100206410ustar00rootroot00000000000000open Ppxlib open Expect_test_common val match_expectation : expression -> Expectation.Raw.t option ppx_expect-0.16.0/src/main.ml000066400000000000000000000155721442175067100160430ustar00rootroot00000000000000open 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) ;; ppx_expect-0.16.0/src/main.mli000066400000000000000000000000001442175067100161700ustar00rootroot00000000000000ppx_expect-0.16.0/test/000077500000000000000000000000001442175067100147435ustar00rootroot00000000000000ppx_expect-0.16.0/test/bad_test.ml000066400000000000000000000023201442175067100170570ustar00rootroot00000000000000module 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 |}] ;; ppx_expect-0.16.0/test/bad_test.mli000066400000000000000000000000551442175067100172330ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/dune000066400000000000000000000002361442175067100156220ustar00rootroot00000000000000(library (name ppx_expect_test) (flags :standard -principal) (libraries expect_test_collector expect_test_matcher) (preprocess (pps ppx_assert ppx_expect)))ppx_expect-0.16.0/test/no-output-patterns/000077500000000000000000000000001442175067100205535ustar00rootroot00000000000000ppx_expect-0.16.0/test/no-output-patterns/dune000066400000000000000000000001221442175067100214240ustar00rootroot00000000000000(library (name ppx_expect_test_no_output_patterns) (preprocess (pps ppx_expect)))ppx_expect-0.16.0/test/no-output-patterns/test.ml000066400000000000000000000001301442175067100220560ustar00rootroot00000000000000let%expect_test _ = print_endline "toto (regexp)"; [%expect {| toto (regexp) |}] ;; ppx_expect-0.16.0/test/no-output-patterns/test.mli000066400000000000000000000000551442175067100222350ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/test_matcher.ml000066400000000000000000000162001442175067100177560ustar00rootroot00000000000000 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) ;; ppx_expect-0.16.0/test/test_matcher.mli000066400000000000000000000000551442175067100201300ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/test_output.ml000066400000000000000000000013341442175067100176750ustar00rootroot00000000000000let%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 |}] ;; ppx_expect-0.16.0/test/test_output.mli000066400000000000000000000000551442175067100200450ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/test_sanitize.ml000066400000000000000000000011671442175067100201670ustar00rootroot00000000000000let%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! |}] ;; ppx_expect-0.16.0/test/test_sanitize.mli000066400000000000000000000000551442175067100203330ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/test_stderr.ml000066400000000000000000000001371442175067100176400ustar00rootroot00000000000000let%expect_test "stderr is collected" = Printf.eprintf "hello\n"; [%expect {| hello |}] ;; ppx_expect-0.16.0/test/test_stderr.mli000066400000000000000000000000551442175067100200100ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/uncaught_exn.ml000066400000000000000000000005461442175067100177720ustar00rootroot00000000000000let%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" |}] ;; ppx_expect-0.16.0/test/uncaught_exn.mli000066400000000000000000000000551442175067100201360ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/unidiomatic_syntax.ml000066400000000000000000000001441442175067100212070ustar00rootroot00000000000000[%%expect_test let _ = Printf.printf "Hello, world.\n"; [%expect {| Hello, world. |}]] ;; ppx_expect-0.16.0/test/unidiomatic_syntax.mli000066400000000000000000000000551442175067100213610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_expect-0.16.0/test/unreachable.ml000066400000000000000000000000701442175067100175430ustar00rootroot00000000000000let%expect_test _ = if false then [%expect.unreachable] ppx_expect-0.16.0/test/unreachable.mli000066400000000000000000000000551442175067100177170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)