diff --git a/Makefile b/Makefile index b148f537..a8e103e1 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,10 @@ all: dune build +doc: + dune build @doc --force + cp -r _build/default/_doc/_html doc/static/api + test: dune runtest diff --git a/alcotest-async.opam b/alcotest-async.opam index 4913cfbc..760349cc 100644 --- a/alcotest-async.opam +++ b/alcotest-async.opam @@ -9,7 +9,7 @@ homepage: "https://github.com/mirage/alcotest" doc: "https://mirage.github.io/alcotest" bug-reports: "https://github.com/mirage/alcotest/issues" depends: [ - "dune" {>= "2.2"} + "dune" {>= "2.4"} "re" {with-test} "fmt" {with-test} "cmdliner" {with-test} diff --git a/alcotest-lwt.opam b/alcotest-lwt.opam index 105b6743..3897a65d 100644 --- a/alcotest-lwt.opam +++ b/alcotest-lwt.opam @@ -9,7 +9,7 @@ homepage: "https://github.com/mirage/alcotest" doc: "https://mirage.github.io/alcotest" bug-reports: "https://github.com/mirage/alcotest/issues" depends: [ - "dune" {>= "2.2"} + "dune" {>= "2.4"} "re" {with-test} "cmdliner" {with-test} "fmt" diff --git a/alcotest-mirage.opam b/alcotest-mirage.opam index 2b292edf..eebc52d2 100644 --- a/alcotest-mirage.opam +++ b/alcotest-mirage.opam @@ -9,7 +9,7 @@ homepage: "https://github.com/mirage/alcotest" doc: "https://mirage.github.io/alcotest" bug-reports: "https://github.com/mirage/alcotest/issues" depends: [ - "dune" {>= "2.2"} + "dune" {>= "2.4"} "re" {with-test} "cmdliner" {with-test} "fmt" diff --git a/alcotest.opam b/alcotest.opam index 32420e86..3a524e2b 100644 --- a/alcotest.opam +++ b/alcotest.opam @@ -19,7 +19,7 @@ homepage: "https://github.com/mirage/alcotest" doc: "https://mirage.github.io/alcotest" bug-reports: "https://github.com/mirage/alcotest/issues" depends: [ - "dune" {>= "2.2"} + "dune" {>= "2.4"} "ocaml" {>= "4.03.0"} "fmt" {>= "0.8.7"} "astring" diff --git a/dune-project b/dune-project index b324f5e0..a458f189 100644 --- a/dune-project +++ b/dune-project @@ -1,6 +1,6 @@ -(lang dune 2.2) -(implicit_transitive_deps false) +(lang dune 2.4) (generate_opam_files true) +(using mdx 0.1) (name alcotest) (source (github mirage/alcotest)) @@ -80,3 +80,6 @@ tests to run. duration lwt logs)) + +(package + (name ppx_alcotest)) diff --git a/examples/bad/bad.ml b/examples/bad/bad.ml index 78caf25d..edaed9d3 100644 --- a/examples/bad/bad.ml +++ b/examples/bad/bad.ml @@ -27,6 +27,8 @@ For more information, please refer to (* Run with [dune exec ./examples/bad/bad.exe] *) +module Alcotest = Alcotest.V1 + (* A module with functions to test *) module To_test = struct let capitalise = Astring.String.Ascii.uppercase diff --git a/examples/dune b/examples/dune index f02afa05..0b349602 100644 --- a/examples/dune +++ b/examples/dune @@ -1,4 +1,4 @@ (tests - (names simple floats) + (names simple floats new) (package alcotest) (libraries alcotest)) diff --git a/examples/floats.ml b/examples/floats.ml index adf80d4c..05b31cbd 100644 --- a/examples/floats.ml +++ b/examples/floats.ml @@ -25,6 +25,8 @@ OTHER DEALINGS IN THE SOFTWARE. For more information, please refer to *) +module Alcotest = Alcotest.V1 + let e = epsilon_float let nan () = diff --git a/examples/lwt/test.ml b/examples/lwt/test.ml index fe5a4e07..ef97afd3 100644 --- a/examples/lwt/test.ml +++ b/examples/lwt/test.ml @@ -26,6 +26,7 @@ For more information, please refer to *) open Lwt.Infix +module Alcotest_lwt = Alcotest_lwt.V1 exception Library_exception diff --git a/examples/new.ml b/examples/new.ml new file mode 100644 index 00000000..2d165feb --- /dev/null +++ b/examples/new.ml @@ -0,0 +1,46 @@ +(* A module with functions to test *) +module To_test = struct + let lowercase = String.lowercase_ascii + let capitalize = String.capitalize_ascii + let str_concat = String.concat "" + let list_concat = List.append +end + +(* The tests *) +let test_lowercase () = + Alcotest.(check string) "same string" "hello!" (To_test.lowercase "hELLO!") + +let test_capitalize () = + Alcotest.(check string) "same string" "World." (To_test.capitalize "world.") + +let test_str_concat () = + Alcotest.(check string) + "same string" "foobar" + (To_test.str_concat [ "foo"; "bar" ]) + +let test_list_concat () = + Alcotest.(check (list int)) + "same lists" [ 1; 2; 3 ] + (To_test.list_concat [ 1 ] [ 2; 3 ]) + +let () = + let open Alcotest in + print_endline ""; + run + ~config:(Config.v ~and_exit:false ()) + ~name:__FILE__ + [ + group ~name:"string-case" + [ + test ~name:"Lower case" test_lowercase; + group ~name:"Further_nested" + [ + test ~name:"alpha" test_lowercase; + test ~name:"beta" test_lowercase; + ]; + test ~name:"Capitalization" test_capitalize; + ]; + group ~name:"string-concat" + [ test ~name:"String mashing" test_str_concat ]; + group ~name:"list-concat" [ test ~name:"List mashing" test_list_concat ]; + ] diff --git a/examples/simple.ml b/examples/simple.ml index 51031fd1..a39da62b 100644 --- a/examples/simple.ml +++ b/examples/simple.ml @@ -25,6 +25,8 @@ OTHER DEALINGS IN THE SOFTWARE. For more information, please refer to *) +module Alcotest = Alcotest.V1 + (* A module with functions to test *) module To_test = struct let lowercase = String.lowercase_ascii @@ -54,9 +56,9 @@ let test_list_concat () = let () = Alcotest.run "Utils" [ - ( "string-case", + ( "String case", [ - Alcotest.test_case "Lower case" `Quick test_lowercase; + Alcotest.test_case "Lower" `Quick test_lowercase; Alcotest.test_case "Capitalization" `Quick test_capitalize; ] ); ( "string-concat", diff --git a/ppx_alcotest.opam b/ppx_alcotest.opam new file mode 100644 index 00000000..3248158a --- /dev/null +++ b/ppx_alcotest.opam @@ -0,0 +1,25 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +maintainer: ["thomas@gazagnaire.org"] +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/alcotest" +bug-reports: "https://github.com/mirage/alcotest/issues" +depends: [ + "dune" {>= "2.4"} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/mirage/alcotest.git" diff --git a/src/alcotest-async/alcotest_async.ml b/src/alcotest-async/alcotest_async.ml index 110af8e9..700fd1d9 100644 --- a/src/alcotest-async/alcotest_async.ml +++ b/src/alcotest-async/alcotest_async.ml @@ -2,21 +2,14 @@ open Core open Async_kernel open Async_unix -module Tester = - Alcotest_engine.Cli.Make - (Alcotest.Unix) - (struct - include Deferred +module M = struct + include Deferred - let bind x f = bind x ~f + let bind x f = bind x ~f - let catch t on_error = - try_with t >>= function Ok a -> return a | Error exn -> on_error exn - end) - -include Tester - -let test_case_sync n s f = test_case n s (fun x -> Deferred.return (f x)) + let catch t on_error = + try_with t >>= function Ok a -> return a | Error exn -> on_error exn +end let run_test timeout name fn args = Clock.with_timeout timeout (fn args) >>| function @@ -26,5 +19,21 @@ let run_test timeout name fn args = (Printf.sprintf "%s timed out after %s" name (Time.Span.to_string_hum timeout)) -let test_case ?(timeout = sec 2.) name s f = - test_case name s (run_test timeout name f) +module Tester = Alcotest_engine.Cli.Make (Alcotest.Unix) (M) +include Tester + +let test_sync ?here ?tag ?tags ~name fn = + test ?here ?tag ?tags ~name (fun x -> Deferred.return (fn x)) + +let test ?here ?tag ?tags ~name ?(timeout = sec 2.) fn = + test ?here ?tag ?tags ~name (run_test timeout name fn) + +module V1 = struct + module Tester = Alcotest_engine.Cli.Make_v1 (Alcotest.Unix) (M) + include Tester + + let test_case_sync n s f = test_case n s (fun x -> Deferred.return (f x)) + + let test_case ?(timeout = sec 2.) name s f = + test_case name s (run_test timeout name f) +end diff --git a/src/alcotest-async/alcotest_async.mli b/src/alcotest-async/alcotest_async.mli index 87e317c6..3562cd39 100644 --- a/src/alcotest-async/alcotest_async.mli +++ b/src/alcotest-async/alcotest_async.mli @@ -17,14 +17,31 @@ (** [Alcotest_async] enables testing functions which return an Async deferred. {!run} returns a deferred which will run the tests when scheduled. *) -include Alcotest_engine.Cli.S with type return = unit Async_kernel.Deferred.t +include + Alcotest_engine.Cli.S + with type 'a m := 'a Async_kernel.Deferred.t + and type 'a test_args := 'a + and type config := Alcotest_engine.Config.t + and type tag := Alcotest_engine.Tag.t + and type tag_set := Alcotest_engine.Tag.Set.t -val test_case : - ?timeout:Core_kernel.Time.Span.t -> - string -> - Alcotest.speed_level -> +val test : + (?timeout:Core_kernel.Time.Span.t -> ('a -> unit Async_kernel.Deferred.t) -> - 'a test_case + 'a test) + Alcotest_engine.Core.identified -val test_case_sync : - string -> Alcotest.speed_level -> ('a -> unit) -> 'a test_case +val test_sync : (('a -> unit) -> 'a test) Alcotest_engine.Core.identified + +module V1 : sig + include Alcotest_engine.Cli.V1 with type return = unit Async_kernel.Deferred.t + + val test_case : + ?timeout:Core_kernel.Time.Span.t -> + string -> + speed_level -> + ('a -> unit Async_kernel.Deferred.t) -> + 'a test_case + + val test_case_sync : string -> speed_level -> ('a -> unit) -> 'a test_case +end diff --git a/src/alcotest-engine/.ocamlformat b/src/alcotest-engine/.ocamlformat new file mode 100644 index 00000000..ad71063c --- /dev/null +++ b/src/alcotest-engine/.ocamlformat @@ -0,0 +1,3 @@ +module-item-spacing = compact +# break-separators = before +# dock-collection-brackets = false diff --git a/src/alcotest-engine/alcotest_engine.ml b/src/alcotest-engine/alcotest_engine.ml index fac70a01..5ad25484 100644 --- a/src/alcotest-engine/alcotest_engine.ml +++ b/src/alcotest-engine/alcotest_engine.ml @@ -1,10 +1,13 @@ -module Test = Test -module Core = Core module Cli = Cli +module Config = Config +module Core = Core module Monad = Monad module Platform = Platform +module Source_code_position = Source_code_position +module Stdlib_ext = Stdlib_ext +module Tag = Tag +module Test = Test module Private = struct - module Utils = Utils module Pp = Pp end diff --git a/src/alcotest-engine/alcotest_engine.mli b/src/alcotest-engine/alcotest_engine.mli index a6c34d6e..761fb61f 100644 --- a/src/alcotest-engine/alcotest_engine.mli +++ b/src/alcotest-engine/alcotest_engine.mli @@ -45,9 +45,13 @@ module Monad = Monad module Platform = Platform (** Defines platform-dependent functions. *) +module Tag = Tag +module Config = Config +module Source_code_position = Source_code_position +module Stdlib_ext = Stdlib_ext + (** These modules are exposed for use internally by other Alcotest packages. They do not provide a stable interface. *) module Private : sig - module Utils = Utils module Pp = Pp end diff --git a/src/alcotest-engine/cli.ml b/src/alcotest-engine/cli.ml index 04ca17ff..372faccc 100644 --- a/src/alcotest-engine/cli.ml +++ b/src/alcotest-engine/cli.ml @@ -15,135 +15,164 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Utils +open! Stdlib_ext +include Cli_intf open Cmdliner +open Cmdliner_syntax open Astring -module IntSet = Set.Make (struct - type t = int +module Arg = struct + include Arg - let compare = (compare : int -> int -> int) -end) - -module type S = sig - include Core.S - - val run : - (?argv:string array -> string -> unit test list -> return) with_options - - val run_with_args : - (?argv:string array -> - string -> - 'a Cmdliner.Term.t -> - 'a test list -> - return) - with_options + let env_var ?docs ?doc x = env_var ?docs ?doc ("ALCOTEST_" ^ x) end -module type MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> - S with type return = unit M.t - -module Make (P : Platform.MAKER) (M : Monad.S) : S with type return = unit M.t = -struct - (** *) - - (** The priority order for determining options should be as follows: - - + 1. if a CLI flag/option is _explicitly_ set, use that; - + 2. if the corresponding environment variable is _explicitly_ set, use - that; - + 3. if the flag/option is set by [run ?argv] - + 4. if the flag/option is passed to [run] directly, use that; - + 5. otherwise, use the default behaviour set by {!Alcotest.Core}. *) - - module C = Core.Make (P) (M) - include C - module P = P (M) - open Cmdliner_syntax - - let set_color = - let env = Arg.env_var "ALCOTEST_COLOR" in - let+ color_flag = - let enum = [ ("auto", `Auto); ("always", `Ansi_tty); ("never", `None) ] in - let color = Arg.enum enum in - let enum_alts = Arg.doc_alts_enum enum in - let doc = - strf - "Colorize the output. $(docv) must be %s. Defaults to %s when \ - running inside Dune, otherwise defaults to %s." - enum_alts (Arg.doc_quote "always") (Arg.doc_quote "auto") - in - Arg.( - value & opt (some color) None & info [ "color" ] ~env ~doc ~docv:"WHEN") - in - let style_renderer = - match color_flag with - | Some `Auto -> None - | Some (`Ansi_tty | `None) as a -> a - | None -> ( - try - (* Default to [always] when running inside Dune *) - let (_ : string) = Sys.getenv "INSIDE_DUNE" in - Some `Ansi_tty - with Not_found -> None) - in - P.setup_std_outputs ?style_renderer () - - let default_cmd ~and_exit config args library_name tests = - let exec_name = Filename.basename Sys.argv.(0) in - let doc = "Run all the tests." in - let term = - let+ () = set_color - and+ cli_config = Config.User.term ~and_exit - and+ args = args in - let config = Config.User.(cli_config || config) in - run_with_args' config library_name args tests - in - (term, Term.info exec_name ~doc) - - let test_cmd config args library_name tests = - let doc = "Run a subset of the tests." in - let term = - let+ () = set_color - and+ cli_config = Config.User.term ~and_exit:true - and+ args = args in - let config = Config.User.(cli_config || config) in - run_with_args' config library_name args tests - in - (term, Term.info "test" ~doc) - - let list_cmd tests = - let doc = "List all available tests." in - ( (let+ () = set_color in - list_tests tests), - Term.info "list" ~doc ) - - let run_with_args' (type a) ~argv config name (args : a Term.t) - (tl : a test list) = - let and_exit = Config.User.and_exit config in - let ( >>= ) = M.bind in - let choices = [ list_cmd tl; test_cmd config args name tl ] in - let exit_or_return result = - if and_exit then exit (Term.exit_status_of_result result) else M.return () +let set_color (module Platform : Platform.S) = + let env = Arg.env_var "COLOR" in + let+ color_flag = + let enum = [ ("auto", `Auto); ("always", `Ansi_tty); ("never", `None) ] in + let color = Arg.enum enum in + let enum_alts = Arg.doc_alts_enum enum in + let doc = + strf + "Colorize the output. $(docv) must be %s. Defaults to %s when running \ + inside Dune, otherwise defaults to %s." + enum_alts (Arg.doc_quote "always") (Arg.doc_quote "auto") in - let result = - Term.eval_choice ?argv - ~catch:and_exit (* Only log exceptions not raised to the user code *) - (default_cmd ~and_exit config args name tl) - choices - in - match result with - | `Ok unit_m -> unit_m >>= fun () -> exit_or_return (`Ok ()) - | (`Help | `Version | `Error `Exn) as result -> exit_or_return result - | `Error (`Parse | `Term) as result -> - exit (Term.exit_status_of_result result) - - let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only - ?show_errors ?json ?filter ?log_dir ?bail ?argv = - Config.User.kcreate (run_with_args' ~argv) ?and_exit ?verbose ?compact - ?tail_errors ?quick_only ?show_errors ?json ?filter ?log_dir ?bail - - let run = - Config.User.kcreate (fun config ?argv name tl -> - run_with_args' config ~argv name (Term.pure ()) tl) -end + Arg.( + value & opt (some color) None & info [ "color" ] ~env ~doc ~docv:"WHEN") + in + let style_renderer = + match color_flag with + | Some `Auto -> None + | Some (`Ansi_tty | `None) as a -> a + | None -> ( + try + (* Default to [always] when running inside Dune *) + let (_ : string) = Sys.getenv "INSIDE_DUNE" in + Some `Ansi_tty + with Not_found -> None) + in + Platform.setup_std_outputs ?style_renderer () + +module Make : MAKER = +functor + (P : Platform.MAKER) + (M : Monad.S) + -> + struct + module C = Core.Make (P) (M) + module P = P (M) + include C + + let run ?here ?(config = Config.User.create ()) ~name suite = + let test_command = + let term = + let+ () = set_color (module P) + and+ cli_config = Config.User.term ~and_exit:false in + let config = Config.User.(cli_config || config) in + run ~name ?here ~config suite + in + (term, Term.info "test") + in + let list_command = + let term = + let+ () = set_color (module P) in + list_tests ~name suite + in + (term, Term.info "list") + in + let exit_or_return result = exit (Term.exit_status_of_result result) in + match Term.eval_choice test_command [ test_command; list_command ] with + | `Ok f -> M.bind f (fun () -> exit_or_return (`Ok ())) + | (`Help | `Version | `Error `Exn) as result -> exit_or_return result + | `Error (`Parse | `Term) as result -> + exit (Term.exit_status_of_result result) + + (* TODO *) + end + +module Make_v1 : V1_MAKER = +functor + (P : Platform.MAKER) + (M : Monad.S) + -> + struct + (** *) + + (** The priority order for determining options should be as follows: + + + 1. if a CLI flag/option is _explicitly_ set, use that; + + 2. if the corresponding environment variable is _explicitly_ set, use + that; + + 3. if the flag/option is set by [run ?argv] + + 4. if the flag/option is passed to [run] directly, use that; + + 5. otherwise, use the default behaviour set by {!Alcotest.Core}. *) + + module C = Core.Make_v1 (P) (M) + include C + module P = P (M) + open Cmdliner_syntax + + let default_cmd ~and_exit config args library_name tests = + let exec_name = Filename.basename Sys.argv.(0) in + let doc = "Run all the tests." in + let term = + let+ () = set_color (module P) + and+ cli_config = Config.User.term ~and_exit + and+ args = args in + let config = Config.User.(cli_config || config) in + run_with_args' config library_name args tests + in + (term, Term.info exec_name ~doc) + + let test_cmd config args library_name tests = + let doc = "Run a subset of the tests." in + let term = + let+ () = set_color (module P) + and+ cli_config = Config.User.term ~and_exit:true + and+ args = args in + let config = Config.User.(cli_config || config) in + run_with_args' config library_name args tests + in + (term, Term.info "test" ~doc) + + let list_cmd suite_name tests = + let doc = "List all available tests." in + ( (let+ () = set_color (module P) in + list_tests suite_name tests), + Term.info "list" ~doc ) + + let run_with_args' (type a) ~argv config name (args : a Term.t) + (tl : a test list) = + let and_exit = Config.User.and_exit config in + let ( >>= ) = M.bind in + let choices = [ list_cmd name tl; test_cmd config args name tl ] in + let exit_or_return result = + if and_exit then exit (Term.exit_status_of_result result) + else M.return () + in + let result = + Term.eval_choice ?argv + ~catch:and_exit (* Only log exceptions not raised to the user code *) + (default_cmd ~and_exit config args name tl) + choices + in + match result with + | `Ok unit_m -> unit_m >>= fun () -> exit_or_return (`Ok ()) + | (`Help | `Version | `Error `Exn) as result -> exit_or_return result + | `Error (`Parse | `Term) as result -> + exit (Term.exit_status_of_result result) + + let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only + ?show_errors ?json ?filter:_ ?log_dir ?bail ?argv = + Config.User.kcreate (run_with_args' ~argv) ?and_exit ?verbose ?compact + ?tail_errors ?quick_only ?show_errors ?json ?filter:None ?log_dir ?bail + + let run ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors + ?json ?filter:_ ?log_dir ?bail ?argv name tl = + Config.User.kcreate + (fun c -> run_with_args' ~argv c name (Term.pure ()) tl) + ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors ?json + ?filter:None ?log_dir ?bail + end diff --git a/src/alcotest-engine/cli.mli b/src/alcotest-engine/cli.mli index 7c2092af..cc3da0ed 100644 --- a/src/alcotest-engine/cli.mli +++ b/src/alcotest-engine/cli.mli @@ -23,42 +23,5 @@ the command line; - all of the regular options to Alcotest.run can be set via CLI flags. *) -module type S = sig - include Core.S - (** @inline *) - - val run : - (?argv:string array -> string -> unit test list -> return) with_options - (** [run n t] runs the test suite [t]. [n] is the name of the tested library. - - The optional argument [and_exit] controls what happens when the function - ends. By default, [and_exit] is set, which makes the function exit with - [0] if everything is fine or [1] if there is an issue. If [and_exit] is - [false], then the function raises [Test_error] on error. - - The optional argument [argv] specifies command line arguments sent to - alcotest like ["--json"], ["--verbose"], etc. Note that this array will be - treated like a regular [Sys.argv], so the array must have at least one - element, and the first element will be treated as if it was the command - name and thus ignored for the purposes of option processing. So - [~argv:\[||\]] is an error, [~argv:\[| "--verbose" |\]] will have no - effect, and [~argv:\[| "ignored"; "--verbose" |\]] will successfully pass - the verbose option. *) - - val run_with_args : - (?argv:string array -> - string -> - 'a Cmdliner.Term.t -> - 'a test list -> - return) - with_options - (** [run_with_args n a t] Similar to [run a t] but take an extra argument [a]. - Every test function will receive as argument the evaluation of the - [Cmdliner] term [a]: this is useful to configure the test behaviors using - the CLI. *) -end - -module type MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> - S with type return = unit M.t - -module Make (P : Platform.MAKER) (M : Monad.S) : S with type return = unit M.t +include Cli_intf.Cli +(** @inline *) diff --git a/src/alcotest-engine/cli_intf.ml b/src/alcotest-engine/cli_intf.ml new file mode 100644 index 00000000..f148c804 --- /dev/null +++ b/src/alcotest-engine/cli_intf.ml @@ -0,0 +1,62 @@ +module type S = sig + include Core.S + (** @inline *) +end + +module type MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> + Core.EXT + with type 'a m := 'a M.t + and type 'a test_args := 'a + and type tag := Tag.t + and type tag_set := Tag.Set.t + and type config := Config.User.t + +module type V1 = sig + include Core.V1 + (** @inline *) + + val run : + (?argv:string array -> string -> unit test list -> return) with_options + (** [run n t] runs the test suite [t]. [n] is the name of the tested library. + + The optional argument [and_exit] controls what happens when the function + ends. By default, [and_exit] is set, which makes the function exit with + [0] if everything is fine or [1] if there is an issue. If [and_exit] is + [false], then the function raises [Test_error] on error. + + The optional argument [argv] specifies command line arguments sent to + alcotest like ["--json"], ["--verbose"], etc. Note that this array will be + treated like a regular [Sys.argv], so the array must have at least one + element, and the first element will be treated as if it was the command + name and thus ignored for the purposes of option processing. So + [~argv:\[||\]] is an error, [~argv:\[| "--verbose" |\]] will have no + effect, and [~argv:\[| "ignored"; "--verbose" |\]] will successfully pass + the verbose option. *) + + val run_with_args : + (?argv:string array -> + string -> + 'a Cmdliner.Term.t -> + 'a test list -> + return) + with_options + (** [run_with_args n a t] Similar to [run a t] but take an extra argument [a]. + Every test function will receive as argument the evaluation of the + [Cmdliner] term [a]: this is useful to configure the test behaviors using + the CLI. *) +end + +module type V1_MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> + V1 with type return = unit M.t + +module type Cli = sig + module type S = S + module type MAKER = MAKER + + module Make : MAKER + + module type V1 = V1 + module type V1_MAKER = V1_MAKER + + module Make_v1 : V1_MAKER +end diff --git a/src/alcotest-engine/config.ml b/src/alcotest-engine/config.ml index 0d4799e6..cb5823fd 100644 --- a/src/alcotest-engine/config.ml +++ b/src/alcotest-engine/config.ml @@ -1,6 +1,6 @@ include Config_intf include Config_intf.Types -open! Utils +open! Stdlib_ext open Cmdliner_syntax (* Keys are configuration properties, which have defaults and may be @@ -128,61 +128,61 @@ module Key = struct Arg.(value & opt (some dir) None & info [ "o" ] ~docv:"DIR" ~doc) end - module Filter = struct - type t = Re.re option * int list option - - let default = (None, None) - - let regex : Re.re Arg.conv = - let parse s = - try Ok Re.(compile @@ Pcre.re s) with - | Re.Perl.Parse_error -> - Error (`Msg "Perl-compatible regexp parse error") - | Re.Perl.Not_supported -> Error (`Msg "unsupported regexp feature") - in - let print = Re.pp_re in - Arg.conv (parse, print) - - let int_range_list : int list Arg.conv = - let exception Invalid_format in - let parse s = - let rec range lower upper acc = - if lower > upper then acc else range (succ lower) upper (lower :: acc) - in - let process_range acc s = - String.cuts ~sep:".." s |> List.map String.to_int |> function - | [ Some i ] -> i :: acc - | [ Some lower; Some upper ] when lower <= upper -> - range lower upper acc - | _ -> raise Invalid_format - in - let ranges = String.cuts ~sep:"," s in - match List.fold_left process_range [] ranges with - | list -> Ok list - | exception Invalid_format -> - Error - (`Msg - "must be a comma-separated list of integers / integer ranges") - in - let print ppf set = Fmt.(braces @@ list ~sep:comma int) ppf set in - Arg.conv (parse, print) - - let term = - let+ name_regex = - let doc = "A regular expression matching the names of tests to run" in - Arg.(value & pos 0 (some regex) None & info [] ~doc ~docv:"NAME_REGEX") - and+ number_filter = - let doc = - "A comma-separated list of test case numbers (and ranges of numbers) \ - to run, e.g: '4,6-10,19'" - in - Arg.( - value - & pos 1 (some int_range_list) None - & info [] ~doc ~docv:"TESTCASES") - in - Some (name_regex, number_filter) - end + (* module Filter = struct + * type t = Re.re option * int list option + * + * let default = (None, None) + * + * let regex : Re.re Arg.conv = + * let parse s = + * try Ok Re.(compile @@ Pcre.re s) with + * | Re.Perl.Parse_error -> + * Error (`Msg "Perl-compatible regexp parse error") + * | Re.Perl.Not_supported -> Error (`Msg "unsupported regexp feature") + * in + * let print = Re.pp_re in + * Arg.conv (parse, print) + * + * let int_range_list : int list Arg.conv = + * let exception Invalid_format in + * let parse s = + * let rec range lower upper acc = + * if lower > upper then acc else range (succ lower) upper (lower :: acc) + * in + * let process_range acc s = + * String.cuts ~sep:".." s |> List.map String.to_int |> function + * | [ Some i ] -> i :: acc + * | [ Some lower; Some upper ] when lower <= upper -> + * range lower upper acc + * | _ -> raise Invalid_format + * in + * let ranges = String.cuts ~sep:"," s in + * match List.fold_left process_range [] ranges with + * | list -> Ok list + * | exception Invalid_format -> + * Error + * (`Msg + * "must be a comma-separated list of integers / integer ranges") + * in + * let print ppf set = Fmt.(braces @@ list ~sep:comma int) ppf set in + * Arg.conv (parse, print) + * + * let term = + * let+ name_regex = + * let doc = "A regular expression matching the names of tests to run" in + * Arg.(value & pos 0 (some regex) None & info [] ~doc ~docv:"NAME_REGEX") + * and+ number_filter = + * let doc = + * "A comma-separated list of test case numbers (and ranges of numbers) \ + * to run, e.g: '4,6-10,19'" + * in + * Arg.( + * value + * & pos 1 (some int_range_list) None + * & info [] ~doc ~docv:"TESTCASES") + * in + * Some (name_regex, number_filter) + * end *) end (* User configs before defaults have been applied. *) @@ -197,9 +197,9 @@ module User = struct quick_only : Quick_only.t option; show_errors : Show_errors.t option; json : Json.t option; - filter : Filter.t option; + filter : Tag.Filter.t option; (* TODO: set Log_dir default internally *) - log_dir : Log_dir.t; + root_log_capture_dir : Log_dir.t; bail : Bail.t option; } @@ -214,7 +214,7 @@ module User = struct show_errors = merge_on (fun t -> t.show_errors); json = merge_on (fun t -> t.json); filter = merge_on (fun t -> t.filter); - log_dir = merge_on (fun t -> t.log_dir); + root_log_capture_dir = merge_on (fun t -> t.root_log_capture_dir); bail = merge_on (fun t -> t.bail); } @@ -225,8 +225,7 @@ module User = struct and+ show_errors = Show_errors.term and+ quick_only = Quick_only.term and+ json = Json.term - and+ filter = Filter.term - and+ log_dir = Log_dir.term + and+ root_log_capture_dir = Log_dir.term and+ bail = Bail.term in { and_exit = Some and_exit; @@ -236,8 +235,8 @@ module User = struct show_errors; quick_only; json; - filter; - log_dir; + filter = None; + root_log_capture_dir; bail; } @@ -245,36 +244,37 @@ module User = struct override config defaults. *) let kcreate : 'a. (t -> 'a) -> 'a with_options = fun f ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors ?json - ?filter ?log_dir ?bail -> + ?filter ?bail ?log_dir -> f { and_exit; verbose; + quick_only; compact; tail_errors; - quick_only; show_errors; json; filter; - log_dir; bail; + root_log_capture_dir = log_dir; } let create : (unit -> t) with_options = kcreate (fun t () -> t) + let quick_only t = Option.value ~default:Quick_only.default t.quick_only let and_exit t = Option.value ~default:And_exit.default t.and_exit end let apply_defaults ~default_log_dir : User.t -> t = fun { and_exit; + quick_only; verbose; compact; tail_errors; - quick_only; show_errors; json; filter; - log_dir; + root_log_capture_dir; bail; } -> let open Key in @@ -286,7 +286,9 @@ let apply_defaults ~default_log_dir : User.t -> t = method quick_only = Option.value ~default:Quick_only.default quick_only method show_errors = Option.value ~default:Show_errors.default show_errors method json = Option.value ~default:Json.default json - method filter = Option.value ~default:Filter.default filter - method log_dir = Option.value ~default:default_log_dir log_dir + method filter = Option.value ~default:Tag.Filter.default filter method bail = Option.value ~default:Bail.default bail + + method root_log_capture_dir = + Option.value_lazy ~default:default_log_dir root_log_capture_dir end diff --git a/src/alcotest-engine/config_intf.ml b/src/alcotest-engine/config_intf.ml index 10159c27..c0f37ffd 100644 --- a/src/alcotest-engine/config_intf.ml +++ b/src/alcotest-engine/config_intf.ml @@ -9,21 +9,21 @@ module Types = struct ; quick_only : bool ; show_errors : bool ; json : bool - ; filter : Re.re option * int list option - ; log_dir : string + ; filter : Tag.Filter.t + ; root_log_capture_dir : string ; bail : bool > type 'a with_options = ?and_exit:bool -> ?verbose:bool -> ?compact:bool -> - ?tail_errors:bound -> + ?tail_errors:[ `Unlimited | `Limit of int ] -> ?quick_only:bool -> ?show_errors:bool -> ?json:bool -> - ?filter:Re.re option * int list option -> - ?log_dir:string -> + ?filter:Tag.Filter.t -> ?bail:bool -> + ?log_dir:string -> 'a end @@ -51,8 +51,9 @@ module type Config = sig (** {2 Accessors} *) + val quick_only : t -> bool val and_exit : t -> bool end - val apply_defaults : default_log_dir:string -> User.t -> t + val apply_defaults : default_log_dir:string Lazy.t -> User.t -> t end diff --git a/src/alcotest-engine/core.ml b/src/alcotest-engine/core.ml index 1da440ec..cca327d4 100644 --- a/src/alcotest-engine/core.ml +++ b/src/alcotest-engine/core.ml @@ -1,5 +1,6 @@ (* * Copyright (c) 2013-2016 Thomas Gazagnaire + * Copyright (c) 2020-2021 Craig Ferguson * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above @@ -15,16 +16,9 @@ *) include Core_intf +include Types open Model -open Utils - -module IntSet = Set.Make (struct - type t = int - - let compare = (compare : int -> int -> int) -end) - -exception Check_error of unit Fmt.t +open Stdlib_ext let () = let print_error = @@ -44,421 +38,448 @@ let () = | Check_error err -> Some (Lazy.force print_error err) | _ -> None) -module Make (P : Platform.MAKER) (M : Monad.S) = struct - module P = P (M) - - module Pp = struct - include Pp - include Pp.Make (P) - end +module Make : MAKER = +functor + (P : Platform.MAKER) + (M : Monad.S) + -> + struct + module P = P (M) + module M = Monad.Extend (M) + + module Suite = struct + include Suite (M) + + let of_tests_exn ~name ~loc tests = + match of_tests ~name ~loc tests with + | Ok s -> s + | Error `Empty_name -> + Pp.user_error + "Suite name cannot cannot be empty. Please pass a non-empty \ + string to `run`." + end + + module Log_capture = Log_capture.Make (M) (P) + + module Pp = struct + include Pp + include Pp.Width_sensitive (P) + end + + open M.Infix + + module T = struct + type 'a t = { + suite : 'a Suite.t; + loc : Lexing.position option; + config : Config.t; + run_id : string; + log_capture : Log_capture.t; + progress_reporter : Pp.Progress_reporter.t option; + mutable errors : unit Fmt.t list; + } - module M = Monad.Extend (M) - module Suite = Suite (M) - include M.Infix - - (** Take a string path and collapse a leading [$HOME] path segment to [~]. *) - let maybe_collapse_home path = - match P.home_directory () with - | Error _ -> path - | Ok home -> ( - (* Astring doesn't have [cut_prefix]. *) - match String.is_prefix ~affix:home path with - | false -> path - | true -> - let tail = - String.Sub.to_string (String.sub ~start:(String.length home) path) - in - "~" ^ tail) - - (* Types *) - type return = unit M.t - type 'a run = 'a -> unit M.t - type speed_level = [ `Quick | `Slow ] - - exception Test_error - - type 'a test_case = string * speed_level * 'a run - - let test_case n s f = (n, s, f) - - type 'a test = string * 'a test_case list - - (* global state *) - type 'a t = { - (* library values. *) - suite : 'a Suite.t; - (* runtime state. *) - mutable errors : unit Fmt.t list; - (* runtime options. *) - max_label : int; - (** Longest test label in the suite, in UTF-8 characters. *) - config : Config.t; - run_id : string; - } - - let empty ~config ~suite_name = - let errors = [] in - let suite = - match Suite.v ~name:suite_name with - | Ok s -> s - | Error `Empty_name -> - Pp.user_error - "Suite name cannot cannot be empty. Please pass a non-empty string \ - to `run`." - in - let max_label = 0 in - let run_id = Uuidm.to_string ~upper:true Uuidm.nil in - { suite; errors; max_label; config; run_id } - - let compare_speed_level s1 s2 = - match (s1, s2) with - | `Quick, `Quick | `Slow, `Slow -> 0 - | `Quick, _ -> 1 - | _, `Quick -> -1 - - (* - Reverse a list, taking at most the first n elements of the original - list. - *) - let rev_head n l = - let rec aux acc n l = - match l with - | x :: xs -> if n > 0 then aux (x :: acc) (n - 1) xs else acc - | [] -> acc - in - aux [] n l - - (* - Show the last lines of a log file. - The goal is to not clutter up the console output. - *) - let read_tail max_lines ic = - let rev_lines = ref [] in - try - while true do - rev_lines := input_line ic :: !rev_lines - done; - assert false - with End_of_file -> - let selected_lines = - match max_lines with - | `Unlimited -> List.rev !rev_lines - | `Limit n -> rev_head n !rev_lines + let random_state = lazy (Random.State.make_self_init ()) + + let random_hex _ = + let state = Lazy.force random_state in + match Random.State.int state 36 with + | n when n < 10 -> Char.chr (n + Char.code '0') + | n -> Char.chr (n - 10 + Char.code 'A') + + let v ~suite ~loc ~log_dir ~config = + let run_id = String.v ~len:8 random_hex in + let log_capture = + Log_capture.active ~root:log_dir ~uuid:run_id + ~suite_name:(Suite.name suite) + in + let progress_reporter = + match config#json with + | true -> None + | false -> + Some + (Pp.Progress_reporter.create ~ppf:Fmt.stdout + ~isatty:(P.stdout_isatty ()) ~compact:config#compact + ~selector_on_first_failure: + (not (config#verbose || config#show_errors))) + in + { + suite; + errors = []; + loc; + config; + run_id; + log_capture; + progress_reporter; + } + end + + open T + + type 'a test = 'a Suite.test + + let tagset ~tags ~tag = + match (tags, tag) with + | None, None -> Tag.Set.empty + | None, Some t -> Tag.Set.(add t empty) + | Some ts, None -> ts + | Some ts, Some t -> Tag.Set.add t ts + + let bt () = match Printexc.get_backtrace () with "" -> "" | s -> "\n" ^ s + + let exn path name pp : Run_result.t = + Exn (path, name, Fmt.(pp ++ const lines (bt ()))) + + let test ?here ?tag ?tags ~name fn = + let tags = tagset ~tags ~tag in + Suite.test ~name ~tags ~loc:here fn + + let group ?here ?tag ?tags ~name ts = + let tags = tagset ~tags ~tag in + Suite.group ~name ~tags ~loc:here ts + + let pp_suite_results t = Pp.suite_results t.config + + let report_event t event = + match t.progress_reporter with + | None -> () + | Some pr -> Pp.Progress_reporter.event pr event + + let _pp_info _t = Pp.info + + let red ppf fmt = + Fmt.kstrf (fun str -> Fmt.(styled `Red string) ppf str) fmt + + let map_pp_unit t ~f ppf = f (fun ppf () -> t ppf) ppf () + + let pp_error t ppf (e : Run_result.t) = + let (path, name), error_fmt = + match e with + | Error (p, f) -> (p, f) + | Exn (p, _, f) -> (p, f) + | _ -> assert false in - let omitted_count = List.length !rev_lines - List.length selected_lines in - let display_lines = - if omitted_count = 0 then selected_lines - else - Fmt.strf "... (omitting %i line%a)" omitted_count Pp.pp_plural - omitted_count - :: selected_lines + let pp_logs ppf () = + let pp_logs = + Log_capture.recover_logs ~tail:t.config#tail_errors t.log_capture + (path @ [ name ]) + in + match (t.config#verbose, pp_logs) with + | true, _ | _, None -> Fmt.pf ppf "%a@," error_fmt () + | false, Some pp_logs -> + let pp_log_dir = + map_pp_unit + ~f:(fun s -> Pp.quoted (Fmt.styled `Cyan s)) + (Log_capture.pp_log_location t.log_capture (path @ [ name ])) + in + Fmt.pf ppf "%t@,Logs saved to %t.@," pp_logs pp_log_dir in - String.concat ~sep:"\n" display_lines ^ "\n" - - let log_dir ~via_symlink t = - let via_symlink = - (* We don't create symlinks on Windows. *) - via_symlink && not Sys.win32 - in - Filename.concat t.config#log_dir - (if via_symlink then Suite.name t.suite else t.run_id) - - let pp_suite_results t = - let log_dir = log_dir ~via_symlink:true t |> maybe_collapse_home in - Pp.suite_results ~log_dir t.config - - let pp_event ~isatty ~prior_error ~tests_so_far t = - let cfg = t.config in - let selector_on_failure = - (not prior_error) && not (cfg#verbose || cfg#show_errors) - in - if not cfg#json then - Pp.event ~isatty ~compact:cfg#compact ~max_label:t.max_label - ~doc_of_test_name:(Suite.doc_of_test_name t.suite) - ~selector_on_failure ~tests_so_far - else Fmt.nop - - let pp_info t = - Pp.info ~max_label:t.max_label - ~doc_of_test_name:(Suite.doc_of_test_name t.suite) - - let output_file t tname = - Filename.concat (log_dir ~via_symlink:true t) (Test_name.file tname) - - let color c ppf fmt = Fmt.(styled c string) ppf fmt - let red_s fmt = color `Red fmt - let red ppf fmt = Fmt.kstrf (fun str -> red_s ppf str) fmt - - let pp_error ~doc_of_test_name ~output_file ~max_label cfg ppf e = - let path, error_fmt = - match e with `Error (p, f) -> (p, f) | `Exn (p, _, f) -> (p, f) - in - let pp_logs ppf () = - let filename = output_file path in - if cfg#verbose || not (Sys.file_exists filename) then - Fmt.pf ppf "%a@," error_fmt () - else - let file = open_in filename in - let output = read_tail cfg#tail_errors file in - close_in file; - Fmt.pf ppf "%s@,Logs saved to %a.@," output - Fmt.(Pp.quoted (styled `Cyan string)) - (maybe_collapse_home filename) - in - Fmt.( - Pp.with_surrounding_box - (const - (Pp.event_line ~margins:3 ~max_label ~doc_of_test_name) - (`Result (path, e))) - ++ pp_logs - ++ Pp.horizontal_rule - ++ cut) - ppf () - - let has_run : Run_result.t -> bool = function - | `Ok | `Error _ | `Exn _ -> true - | `Skip | `Todo _ -> false - - let bt () = match Printexc.get_backtrace () with "" -> "" | s -> "\n" ^ s - let exn path name pp = `Exn (path, name, Fmt.(pp ++ const lines (bt ()))) - - let protect_test path (f : 'a run) : 'a -> Run_result.t M.t = - fun args -> - M.catch - (fun () -> f args >|= fun () -> `Ok) - ((function - | Check_error err -> - let err = Fmt.(err ++ const string (bt ())) in - `Error (path, err) - | Failure s -> exn path "failure" Fmt.(const string s) - | Invalid_argument s -> exn path "invalid" Fmt.(const string s) - | e -> exn path "exception" Fmt.(const exn e)) - >> M.return) - - type running_state = { tests_so_far : int; first_error : int option } - (** State that is kept during the test executions. *) - - let perform_test t args { tests_so_far; first_error } suite = - let open Suite in - let test = suite.fn in - let print_event = - pp_event t - ~prior_error:(Option.is_some first_error) - ~tests_so_far ~isatty:(P.stdout_isatty ()) Fmt.stdout - in - M.return () >>= fun () -> - print_event (`Start suite.name); - Fmt.(flush stdout) () (* Show event before any test stderr *); - test args >|= fun result -> - (* Store errors *) - let errored : bool = - let pp_error = - pp_error - ~doc_of_test_name:(Suite.doc_of_test_name t.suite) - ~output_file:(output_file t) ~max_label:t.max_label t.config + Fmt.( + Pp.with_surrounding_box + (const Pp.event_line { index = (path, name); type_ = Result e }) + ++ pp_logs + ++ Pp.horizontal_rule + ++ cut) + ppf () + + type running_state = { + tests_so_far : int; + first_error : int option; + failures : int; + } + (** State that is kept during the test executions. *) + + let protect_test : + 'a. Run_result.index -> ('a -> unit M.t) -> 'a -> Run_result.t M.t = + fun path f args -> + M.catch + (fun () -> f args >|= fun () -> Run_result.Ok) + ((function + | Check_error err -> + let err = Fmt.(err ++ const string (bt ())) in + Run_result.Error (path, err) + | Failure s -> exn path "failure" Fmt.(const string s) + | Invalid_argument s -> exn path "invalid" Fmt.(const string s) + | e -> exn path "exception" Fmt.(const exn e)) + >> M.return) + + let perform_test t args ~path ~(name : Safe_string.t) test acc = + let test = protect_test (path, name) test in + M.return () >>= fun () -> + report_event t { index = (path, name); type_ = Start }; + Fmt.(flush stdout) () (* Show event before any test stderr *); + (if t.config#verbose then fun x -> x + else Log_capture.with_captured_logs t.log_capture ~path ~name) + test args + >|= fun (result : Run_result.t) -> + (* Store errors *) + let errored : bool = + let error, errored = + if Run_result.is_failure result then + ([ Fmt.const (pp_error t) result ], true) + else ([], false) + in + t.errors <- error @ t.errors; + errored in - let error, errored = - match result with - | (`Error _ | `Exn (_, _, _)) as e -> ([ Fmt.const pp_error e ], true) - | _ -> ([], false) + (* Show any remaining test output before the event *) + Fmt.(flush stdout ()); + Fmt.(flush stderr ()); + report_event t { index = (path, name); type_ = Result result }; + let error = if errored then Some acc.tests_so_far else None in + let acc = + { + tests_so_far = acc.tests_so_far + 1; + first_error = Option.(acc.first_error || error); + failures = (acc.failures + if errored then 1 else 0); + } in - t.errors <- error @ t.errors; - errored - in - (* Show any remaining test output before the event *) - Fmt.(flush stdout ()); - Fmt.(flush stderr ()); - print_event (`Result (suite.name, result)); - let error = if errored then Some tests_so_far else None in - let state = - { - tests_so_far = tests_so_far + 1; - first_error = Option.(first_error || error); - } - in - (state, result) - - let perform_tests t tests args = - let currently_bailing acc = - Option.is_some acc.first_error && t.config#bail - in - M.List.fold_map_s - (fun acc test -> - if currently_bailing acc then - M.return ({ acc with tests_so_far = succ acc.tests_so_far }, `Skip) - else perform_test t args acc test) - { tests_so_far = 0; first_error = None } - tests - >|= fun (state, test_results) -> - let () = - if currently_bailing state then - match state.tests_so_far - Option.get_exn state.first_error - 1 with - | n when n > 0 -> - Fmt.pr "@\n %a@\n" - Fmt.(styled `Faint string) - (Fmt.str "... with %d subsequent test%a skipped." n Pp.pp_plural n) - | 0 -> () - | _ -> assert false - in - test_results - - let skip_fun _ = M.return `Skip - let skip_label test_case = Suite.{ test_case with fn = skip_fun } - - let filter_test_case (regexp, cases) = - let regexp_match = - match regexp with - | None -> fun _ -> true - | Some r -> fun n -> Re.execp r n - in - let index_match = - match cases with - | None -> fun _ -> true - | Some ints -> - let set = IntSet.of_list ints in - fun i -> IntSet.mem i set - in - fun test_case -> - let name, index = - let tn = test_case.Suite.name in - Test_name.(name tn, index tn) + (acc, result) + + exception Test_error + + let perform_tests : type a. a t -> a -> int M.t = + fun t args -> + let currently_bailing acc = + Option.is_some acc.first_error && t.config#bail in - regexp_match name && index_match index - - let filter_test_cases ~subst path test_cases = - let filter_test_case = filter_test_case path in - test_cases - |> List.filter_map (fun tc -> - if filter_test_case tc then Some tc - else if subst then Some (skip_label tc) - else None) - - let redirect_test_output t test_case = - let output_file = output_file t test_case.Suite.name in - let fn args = - P.with_redirect output_file (fun () -> - test_case.fn args >|= fun result -> - Pp.rresult_error Fmt.stdout result; - result) - in - { test_case with fn } - - let select_speed speed_level (test_case : 'a Suite.test_case as 'tc) : 'tc = - if compare_speed_level test_case.speed_level speed_level >= 0 then test_case - else Suite.{ test_case with fn = skip_fun } - - let result t test args = - P.prepare ~base:t.config#log_dir - ~dir:(log_dir ~via_symlink:false t) - ~name:(Suite.name t.suite); - let start_time = P.time () in - let test = - if t.config#verbose then test else List.map (redirect_test_output t) test - in - let speed_level = if t.config#quick_only then `Quick else `Slow in - let test = List.map (select_speed speed_level) test in - perform_tests t test args >|= fun results -> - let time = P.time () -. start_time in - let success = List.length (List.filter has_run results) in - let failures = List.length (List.filter Run_result.is_failure results) in - Pp.{ time; success; failures; errors = List.rev t.errors } - - let list_registered_tests t () = - Suite.tests t.suite - |> List.map (fun t -> t.Suite.name) - |> List.sort Test_name.compare - |> Fmt.(list ~sep:(const string "\n") (pp_info t) stdout) - - let register (type a) (t : a t) (name, (ts : a test_case list)) : a t = - let max_label = max t.max_label (String.length_utf8 name) in - let test_details = - List.mapi - (fun index (doc, speed, test) -> - let path = Test_name.v ~name ~index in - let doc = - if doc = "" || doc.[String.length doc - 1] = '.' then doc - else doc ^ "." - in - let test a = protect_test path test a in - (path, doc, speed, test)) - ts - in - let suite = - List.fold_left - (fun acc td -> - match Suite.add acc td with - | Ok acc -> acc - | Error (`Duplicate_test_path path) -> - Fmt.kstr Pp.user_error "Duplicate test path: `%s'" path) - t.suite test_details - in - { t with suite; max_label } - - let register_all t cases = List.fold_left register t cases - - let run_tests t () args = - let filter = t.config#filter in - let suite = Suite.tests t.suite in - let is_empty = filter_test_cases ~subst:false filter suite = [] in - (if is_empty && filter <> (None, None) then ( - Fmt.(pf stderr) - "%a\n" red - "Invalid request (no tests to run, filter skipped everything)!"; - exit 1) - else - let tests = filter_test_cases ~subst:true filter suite in - result t tests args) - >|= fun result -> - (pp_suite_results t) Fmt.stdout result; - result.failures - - let default_log_dir () = - let fname_concat l = List.fold_left Filename.concat "" l in - fname_concat [ P.getcwd (); "_build"; "_tests" ] - - type 'a with_options = 'a Config.with_options - - let list_tests (type a) (tl : a test list) = - (* TODO: refactor [register_all] to not require dummy state *) - let config = - Config.apply_defaults ~default_log_dir:"" - (Config.User.create ()) - in - let t = register_all (empty ~config ~suite_name:"") tl in - list_registered_tests t (); - M.return () - - let run_with_args' (config : Config.User.t) name (type a) (args : a) - (tl : a test list) = - let config = - Config.apply_defaults ~default_log_dir:(default_log_dir ()) config - in - let random_state = Random.State.make_self_init () in - let run_id = Uuidm.v4_gen random_state () |> Uuidm.to_string ~upper:true in - let t = { (empty ~config ~suite_name:name) with run_id } in - let t = register_all t tl in - ( (* Only print inside the concurrency monad *) + let test_it = perform_test t args in M.return () >>= fun () -> - let open Fmt in - pr "Testing %a.@," (Pp.quoted Fmt.(styled `Bold Suite.pp_name)) t.suite; - pr "@[%a@]" - (styled `Faint (fun ppf () -> - pf ppf "This run has ID %a.@,@," (Pp.quoted string) run_id)) + Fmt.pr "Testing %a.@,@[%a@]" + (Pp.quoted Fmt.(styled `Bold Suite.pp_name)) + t.suite + Fmt.( + styled `Faint (fun ppf () -> + pf ppf "This run has ID %a.@,@," (Pp.quoted string) t.run_id)) (); - run_tests t () args ) - >|= fun test_failures -> - match (test_failures, t.config#and_exit) with - | 0, true -> exit 0 - | 0, false -> () - | _, true -> exit 1 - | _, false -> raise Test_error - - let run' config name (tl : unit test list) = run_with_args' config name () tl - - let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only - ?show_errors ?json ?filter ?log_dir ?bail = - Config.User.kcreate run_with_args' ?and_exit ?verbose ?compact ?tail_errors - ?quick_only ?show_errors ?json ?filter ?log_dir ?bail - - let run = Config.User.kcreate run' -end + let start_time = P.time () in + let results = + Suite.foldi_until t.suite ~filter:t.config#filter + ~init:{ tests_so_far = 0; first_error = None; failures = 0 } + ~finish:(fun x -> x) + ~group:(fun _ctx acc _ -> + if currently_bailing acc then M.return (Stop acc) + else M.return (Continue acc)) + ~test:(fun ctx (acc : running_state) test -> + if currently_bailing acc then M.return (Stop acc) + else + match test with + | `Run f -> + test_it ~path:ctx#path ~name:ctx#name f acc >|= fun (x, _) -> + Continue x + | `Skip -> + report_event t + { index = (ctx#path, ctx#name); type_ = Result Skip }; + M.return (Continue acc)) + in + results >|= fun results -> + let () = + if currently_bailing results then + match + results.tests_so_far - Option.get_exn results.first_error - 1 + with + | n when n > 0 -> + Fmt.pr "@\n %a@\n" + Fmt.(styled `Faint string) + (Fmt.str "... with %d subsequent test%a skipped." n Pp.plural n) + | 0 -> () + | _ -> assert false + in + let time = P.time () -. start_time + and success = results.tests_so_far + and failures = results.failures + and errors = List.rev t.errors in + (pp_suite_results t) Fmt.stdout Pp.{ time; success; failures; errors }; + failures + + (* + let filter_test_case (regexp, cases) test_case = + let n, i = + let tn = test_case.Suite.name in + Test_name.(name tn, index tn) + in + let regexp_match = function None -> true | Some r -> Re.execp r n in + let case_match = function None -> true | Some set -> IntSet.mem i set in + regexp_match regexp && case_match cases + + let filter_test_cases ~subst path test_cases = + test_cases + |> List.filter_map (fun tc -> + if filter_test_case path tc then Some tc + else if subst then Some (skip_label tc) + else None) + *) + + let list_tests ?here ?config:_ ~name tests = + let suite = Suite.of_tests_exn ~name ~loc:here tests in + Fmt.pr "@[%a@]@." Suite.pp suite; + M.return () + + (* Suite.tests t.suite + * |> List.map (fun t -> t.Suite.name) + * |> List.sort Test_name.compare + * |> Fmt.(list ~sep:(const string "\n") (pp_info t) stdout) *) + + (* let register (type a) (t : a t) (name, (ts : a test_case list)) : a t = + * let max_label = max t.max_label (String.length_utf8 name) in + * let test_details = + * List.mapi + * (fun index (doc, speed, test) -> + * let path = Test_name.v ~name ~index in + * let doc = + * if doc = "" || doc.[String.length doc - 1] = '.' then doc + * else doc ^ "." + * in + * let test a = protect_test path test a in + * (path, doc, speed, test)) + * ts + * in + * let suite = + * List.fold_left + * (fun acc td -> + * match Suite.add acc td with + * | Ok acc -> acc + * | Error (`Duplicate_test_path path) -> + * Fmt.kstr Pp.user_error "Duplicate test path: `%s'" path) + * t.suite test_details + * in + * { t with suite; max_label } *) + + (* let tests = filter_test_cases ~subst:true labels suite in *) + (* result t args) + * >|= fun result -> + * (pp_suite_results t) Fmt.stdout result; + * result.failures *) + + let default_log_dir = + let ( / ) = Filename.concat in + lazy (P.getcwd () / "_build" / "_tests") + + let run_with_args ?here ?(config = Config.User.create ()) ~name test_ctx + tests = + let config = Config.apply_defaults ~default_log_dir config in + let suite = Suite.of_tests_exn ~name ~loc:here tests in + let at_least_one_test = + Suite.foldi_until suite ~filter:config#filter ~init:() + ~finish:(fun () -> false) + ~test: + (fun _ () -> function + | `Run _ -> M.return (Stop true) + | `Skip -> M.return (Continue ())) + in + at_least_one_test >>= fun at_least_one_test -> + if not at_least_one_test then ( + Fmt.(pf stderr) + "%a\n" red + "Invalid request (no tests to run, filter skipped everything)!"; + exit 1); + let t = + T.v ~suite ~loc:here ~log_dir:config#root_log_capture_dir ~config + in + perform_tests t test_ctx >|= fun test_failures -> + match (test_failures, config#and_exit) with + | 0, true -> exit 0 + | 0, false -> () + | _, true -> exit 1 + | _, false -> raise Test_error + + let run ?here ?config ~name suite = + run_with_args ?here ?config ~name () suite + end + +module Make_v1 : V1_MAKER = +functor + (P : Platform.MAKER) + (M : Monad.S) + -> + struct + module X = Make (P) (M) + module P = P (M) + module M = Monad.Extend (M) + open M.Infix + + (* Types *) + type return = unit M.t + type 'a run = 'a -> unit M.t + type speed_level = [ `Quick | `Slow ] + + exception Test_error + + type 'a test_case = string * speed_level * 'a run + + let test_case n s f = (n, s, f) + + type 'a test = string * 'a test_case list + + type 'a with_options = + ?and_exit:bool -> + ?verbose:bool -> + ?compact:bool -> + ?tail_errors:[ `Unlimited | `Limit of int ] -> + ?quick_only:bool -> + ?show_errors:bool -> + ?json:bool -> + (* TODO: changes *) ?filter:(name:string -> index:int -> [ `Run | `Skip ]) -> + ?log_dir:string -> + ?bail:bool -> + 'a + + let position_tag = Tag.spec ~name:"index" ~pp:Fmt.(using snd int) + + let migrate_suite ts = + ListLabels.map ts ~f:(fun (group_name, children) -> + let children = + ListLabels.mapi children ~f:(fun i (name, speed_level, fn) -> + let speed = + match speed_level with + | `Quick -> Tag.Speed_level.quick + | `Slow -> Tag.Speed_level.slow + in + let position = Tag.V (position_tag, (group_name, i)) in + let tags = Tag.Set.(empty |> add speed |> add position) in + X.test ~name ~tags fn) + in + X.group ~name:group_name children) + + let run_main ~filter:position_filter config name args tl = + let filter tags = + let speed_level = + match Tag.Set.find Tag.Speed_level.tag tags with + | Some `Slow -> if Config.User.quick_only config then `Skip else `Run + | Some `Quick | None -> `Run + in + let position = + match position_filter with + | None -> `Run + | Some p -> ( + match Tag.Set.find position_tag tags with + | None -> `Run + | Some (name, index) -> p ~name ~index) + in + match (speed_level, position) with `Run, `Run -> `Run | _ -> `Skip + in + let config = Config.User.(create ~filter () || config) in + let suite = migrate_suite tl in + X.run_with_args ~name ~config args suite >|= fun _ -> exit 0 + + let list_tests name (ts : _ test list) = + let suite = migrate_suite ts in + X.list_tests ~name suite + + let run' ~filter config name (tl : unit test list) = + run_main ~filter config name () tl + + let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only + ?show_errors ?json ?filter ?log_dir ?bail = + Config.User.kcreate (run_main ~filter) ?and_exit ?verbose ?compact + ?tail_errors ?quick_only ?show_errors ?json ?filter:None ?log_dir ?bail + + let run : (string -> unit test list -> return) with_options = + fun ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors ?json + ?filter ?log_dir ?bail -> + Config.User.kcreate (run' ~filter) ?and_exit ?verbose ?compact + ?tail_errors ?quick_only ?show_errors ?json ?filter:None ?log_dir ?bail + + let run' = run' ~filter:None + let run_with_args' a b c d = run_main ~filter:None a b c d + end diff --git a/src/alcotest-engine/core_intf.ml b/src/alcotest-engine/core_intf.ml index ddac85ed..23420575 100644 --- a/src/alcotest-engine/core_intf.ml +++ b/src/alcotest-engine/core_intf.ml @@ -15,7 +15,77 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Types = struct + exception Check_error of unit Fmt.t + + (* TODO(4.08): replace with local type substitution *) + type 'a identified = + ?here:Lexing.position -> ?tag:Tag.t -> ?tags:Tag.Set.t -> name:string -> 'a + (** A test suite is a tree of named test cases, with named internal nodes. + This type defines the metadata associated with each node in the tree: *) +end + module type S = sig + (* These types are intended to be destructively-substituted by various + backends. *) + + type 'a m + type 'a test_args + type tag + type tag_set + type config + + type 'a test + (** The type of unit tests. *) + + type 'a extra_info := + ?here:Source_code_position.here -> ?tag:tag -> ?tags:tag_set -> 'a + (** Tests and test groups can be located by attaching source code positions to + them. *) + + val test : (name:string -> ('a -> unit m) test_args -> 'a test) extra_info + (** [test ~name f] is a suite containing a single named test that runs [f].*) + + val group : (name:string -> 'a test list -> 'a test) extra_info + (** [test_group ~name ts] *) + + val run : + ?here:Source_code_position.here -> + ?config:config -> + name:string -> + unit test list -> + unit m + + val run_with_args : + ?here:Source_code_position.here -> + ?config:config -> + name:string -> + 'a -> + 'a test list -> + unit m +end + +(** Extensions to {!S} for use by backends. *) +module type EXT = sig + include S + + val list_tests : + ?here:Source_code_position.here -> + ?config:config -> + name:string -> + _ test list -> + unit m +end + +module type MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> + EXT + with type 'a m := 'a M.t + and type 'a test_args := 'a + and type config := Config.User.t + and type tag := Tag.t + and type tag_set := Tag.Set.t + +module type V1 = sig type return (** The return type of each test case run by Alcotest. For the standard {!Alcotest} module, [return = unit]. The concurrent backends @@ -42,7 +112,7 @@ module type S = sig (** A test is a UTF-8 encoded name and a list of test cases. The name can be used for filtering which tests to run on the CLI. *) - val list_tests : 'a test list -> return + val list_tests : string -> 'a test list -> return (** Print all of the test cases in a human-readable form *) type 'a with_options = @@ -53,7 +123,7 @@ module type S = sig ?quick_only:bool -> ?show_errors:bool -> ?json:bool -> - ?filter:Re.re option * int list option -> + ?filter:(name:string -> index:int -> [ `Run | `Skip ]) -> ?log_dir:string -> ?bail:bool -> 'a @@ -73,7 +143,8 @@ module type S = sig - [json] (default [false]). Print test results in a JSON-compatible format. - [log_dir] (default ["$PWD/_build/_tests/"]). The directory in which to - log the output of the tests (if [verbose] is not set). + log the output of the tests (if [verbose] is not set). log the output of + the tests (if [verbose] is not set). - [bail] (default [false]). If true, stop running the tests after the first failure. *) @@ -81,22 +152,30 @@ module type S = sig val run_with_args : (string -> 'a -> 'a test list -> return) with_options end -module type MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> sig - include S with type return = unit M.t +module type V1_MAKER = functor (P : Platform.MAKER) (M : Monad.S) -> sig + include V1 with type return = unit M.t val run' : Config.User.t -> string -> unit test list -> return val run_with_args' : Config.User.t -> string -> 'a -> 'a test list -> return end module type Core = sig + include module type of Types + module type S = S + module type EXT = EXT module type MAKER = MAKER - exception Check_error of unit Fmt.t - module Make : MAKER (** Functor for building a tester that sequences tests of type [('a -> unit M.t)] within a given concurrency monad [M.t]. The [run] and [run_with_args] functions must be scheduled in a global event loop. Intended for use by the {!Alcotest_lwt} and {!Alcotest_async} backends. *) + + (** V1 Alcotest API *) + + module type V1 = V1 + module type V1_MAKER = V1_MAKER + + module Make_v1 : V1_MAKER end diff --git a/src/alcotest-engine/log_capture.ml b/src/alcotest-engine/log_capture.ml new file mode 100644 index 00000000..6743e446 --- /dev/null +++ b/src/alcotest-engine/log_capture.ml @@ -0,0 +1,119 @@ +include Log_capture_intf +open Stdlib_ext + +module Make + (Monad : Monad.Extended) + (Platform : Platform.S with type 'a promise := 'a Monad.t) = +struct + open Monad.Infix + + type state = { root : string; uuid : string; suite_name : string } + type location = Suite of state | Null of Platform.file_descriptor + type t = Inactive | Redirect of location + + let inactive = Inactive + + let discard () = + let null = + Platform.open_ + (match Sys.os_type with "Win32" -> "NUL" | _ -> "/dev/null") + in + Redirect (Null null) + + let active ~root ~uuid ~suite_name = + Platform.prepare ~root ~uuid ~name:suite_name; + Redirect (Suite { root; uuid; suite_name }) + + let test_log_path ~root ~path ~name = + ListLabels.fold_right (root :: path) + ~init:(Safe_string.to_string name) + ~f:Filename.concat + + let with_captured_logs t ~path ~name f x = + match t with + | Inactive -> f x + | Redirect where -> + let path = List.map Safe_string.to_string path in + let fd = + match where with + | Null fd -> fd + | Suite { root; _ } -> + let parent = + ListLabels.fold_left path ~init:root ~f:Filename.concat + in + Platform.mkdir_p parent; + Platform.open_ (test_log_path ~root ~path ~name) + in + Monad.return () >>= fun () -> + Platform.with_redirect fd (fun () -> f x) >|= fun a -> + (match where with Suite _ -> Platform.close fd | _ -> ()); + a + + let log_dir { suite_name; uuid; root } = + (* We don't create symlinks on Windows. *) + let via_symlink = not Sys.win32 in + Filename.concat root (if via_symlink then suite_name else uuid) + + let output_file t index = + match t with + | Redirect (Suite state) -> + ListLabels.fold_left index ~init:(log_dir state) ~f:(fun acc x -> + Filename.concat acc (Safe_string.to_string x)) + | _ -> assert false + + (** Take a string path and collapse a leading [$HOME] path segment to [~]. *) + let maybe_collapse_home path = + match Platform.home_directory () with + | Error _ -> path + | Ok home -> ( + (* Astring doesn't have [cut_prefix]. *) + match String.is_prefix ~affix:home path with + | false -> path + | true -> + let tail = + String.Sub.to_string (String.sub ~start:(String.length home) path) + in + "~" ^ tail) + + let pp_log_location t idx ppf = + output_file t idx |> maybe_collapse_home |> Format.pp_print_string ppf + + let rev_lines_of_input_channel ic = + let rev_lines = ref [] in + try + while true do + rev_lines := input_line ic :: !rev_lines + done; + assert false + with End_of_file -> !rev_lines + + let read_tail max_lines ic = + let rev_lines = rev_lines_of_input_channel ic in + let selected_lines = + match max_lines with + | `Unlimited -> List.rev rev_lines + | `Limit n -> List.rev_take n rev_lines + in + let omitted_count = List.length rev_lines - List.length selected_lines in + let display_lines = + if omitted_count = 0 then selected_lines + else + Fmt.strf "... (omitting %i line%a)" omitted_count Pp.plural + omitted_count + :: selected_lines + in + String.concat ~sep:"\n" display_lines ^ "\n" + + let recover_logs t ~tail idx = + let filename = output_file t idx in + (* Fmt.epr "Recovering logs from %s\n%!" filename; *) + match Platform.file_exists filename with + | false -> None + | true -> + Some + (fun ppf -> + let file = open_in filename in + let output = read_tail tail file in + close_in file; + Format.pp_print_string ppf output) +end diff --git a/src/alcotest-engine/log_capture.mli b/src/alcotest-engine/log_capture.mli new file mode 100644 index 00000000..4257fc63 --- /dev/null +++ b/src/alcotest-engine/log_capture.mli @@ -0,0 +1,2 @@ +include Log_capture_intf.Log_capture +(** @inline *) diff --git a/src/alcotest-engine/log_capture_intf.ml b/src/alcotest-engine/log_capture_intf.ml new file mode 100644 index 00000000..4374378d --- /dev/null +++ b/src/alcotest-engine/log_capture_intf.ml @@ -0,0 +1,61 @@ +open Stdlib_ext + +(** Running tests have their output hidden by default to avoid cluttering the + Alcotest display with irrelevant output. However, we (usually) want to keep + the logs on disk so that we can re-display them if a test fails. + + Logs are stored with the following structure: + + {[ + + β”œβ”€β”€ E0965BF9/... + β”œβ”€β”€ 6DDB68D5/ ;; UUID.time_low for each test run + β”‚ β”‚ + β”‚ β”œβ”€β”€ first_group/ ;; Directories for test groups + β”‚ β”‚ β”œβ”€β”€ test_foo.output ;; ... containing files for individual tests + β”‚ β”‚ └── test_bar.output + β”‚ └── second_group/ + β”‚ + β”œβ”€β”€ latest/ ;; Symlink to most recent UUID + └── / ;; Symlink to most recent UUID + ]} *) +module type S = sig + type t + type 'a monad + + (** Constructors *) + + val inactive : t + val discard : unit -> t + val active : root:string -> uuid:string -> suite_name:string -> t + + val with_captured_logs : + t -> + path:Safe_string.t list -> + name:Safe_string.t -> + ('a -> 'b monad) -> + 'a -> + 'b monad + (** Capture all logs for a given test run. *) + + val pp_log_location : t -> Safe_string.t list -> Format.formatter -> unit + (** Print the file containing the trace of a particular test. Raises an + exception if traces are not being recorded. *) + + val recover_logs : + t -> + tail:[ `Unlimited | `Limit of int ] -> + Safe_string.t list -> + (Format.formatter -> unit) option + (** Print the logs for a given test to the given formatter. [tail] determines + whether to show all lines in the captured log or just a suffix of them. *) +end + +module type Log_capture = sig + module type S = S + + module Make + (Monad : Monad.Extended) + (_ : Platform.S with type 'a promise := 'a Monad.t) : + S with type 'a monad := 'a Monad.t +end diff --git a/src/alcotest-engine/model.ml b/src/alcotest-engine/model.ml index 8f9b32d7..3b1c7e67 100644 --- a/src/alcotest-engine/model.ml +++ b/src/alcotest-engine/model.ml @@ -1,158 +1,165 @@ -open Utils - -type speed_level = [ `Quick | `Slow ] - -(** Given a UTF-8 encoded string, escape any characters not considered - "filesystem safe" as their [U+XXXX] notation form. *) -let escape str = - let add_codepoint buf uchar = - Uchar.to_int uchar |> Fmt.str "U+%04X" |> Buffer.add_string buf - in - let buf = Buffer.create (String.length str * 2) in - let get_normalized_char _ _ u = - match u with - | `Uchar u -> - if Uchar.is_char u then - match Uchar.to_char u with - | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-' | ' ' | '.') as c - -> - Buffer.add_char buf c - | _ -> add_codepoint buf u - else add_codepoint buf u - | `Malformed _ -> Uutf.Buffer.add_utf_8 buf Uutf.u_rep - in - Uutf.String.fold_utf_8 get_normalized_char () str; - Buffer.contents buf - -module Test_name : sig - type t - - val v : name:string -> index:int -> t - val name : t -> string - val index : t -> int - - val pp : t Fmt.t - (** Pretty-print the unescaped test-case name *) - - val file : t -> string - (** An escaped form of the test name with [.output] suffix. *) - - val length : t -> int - (** The approximate number of terminal columns consumed by [pp_name]. *) - - val compare : t -> t -> int - (** Order lexicographically by name, then by index. *) -end = struct - type t = { name : string; file : string; index : int } - - let index { index; _ } = index - - let v ~name ~index = - let file = - let name = name |> escape |> function "" -> "" | n -> n ^ "." in - Fmt.str "%s%03d.output" name index - in - { name; file; index } - - let pp = Fmt.using (fun { name; _ } -> name) Fmt.string - let name { name; _ } = name - let file { file; _ } = file - let length = name >> Uutf.String.fold_utf_8 (fun a _ _ -> a + 1) 0 - - let compare t t' = - match String.compare t.name t'.name with - | 0 -> (compare : int -> int -> int) t.index t'.index - | n -> n -end +open Stdlib_ext module Run_result = struct - type t = - [ `Ok - | `Exn of Test_name.t * string * unit Fmt.t - | `Error of Test_name.t * unit Fmt.t - | `Skip - | `Todo of string ] - - (** [is_failure] holds for test results that are error states. *) - let is_failure : t -> bool = function - | `Ok | `Skip -> false - | `Error _ | `Exn _ | `Todo _ -> true -end - -module Suite (M : Monad.S) : sig - type 'a t - - type 'a test_case = { - name : Test_name.t; - speed_level : speed_level; - fn : 'a -> Run_result.t M.t; - } - - val v : name:string -> (_ t, [> `Empty_name ]) result - (** Construct a new suite, given a non-empty [name]. Test cases must be added - with {!add}. *) + type index = Safe_string.t list * Safe_string.t - val name : _ t -> string - (** An escaped form of the suite name. *) + type t = + | Ok + | Exn of index * string * unit Fmt.t + | Error of index * unit Fmt.t + | Skip + | Todo of string - val pp_name : _ t Fmt.t - (** Pretty-print the unescaped suite name. *) + let is_failure = function + | Ok | Skip -> false + | Error _ | Exn _ | Todo _ -> true - val add : - 'a t -> - Test_name.t * string * speed_level * ('a -> Run_result.t M.t) -> - ('a t, [ `Duplicate_test_path of string ]) result + let has_run = function Ok | Error _ | Exn _ -> true | Skip | Todo _ -> false +end - val tests : 'a t -> 'a test_case list - val doc_of_test_name : 'a t -> Test_name.t -> string -end = struct +module Suite (M : Monad.S) = struct module String_set = Set.Make (String) - - type 'a test_case = { - name : Test_name.t; - speed_level : speed_level; - fn : 'a -> Run_result.t M.t; - } + module M = Monad.Extend (M) + open M.Infix + + type 'a test = + | Test of { + name : Safe_string.t; + loc : Lexing.position option; + tags : Tag.Set.t; + fn : 'a -> unit M.t; + } + | Group of { + name : Safe_string.t; + loc : Lexing.position option; + tags : Tag.Set.t; + children : 'a test list; + } + + let test ~name ~loc ~tags fn = + let name = Safe_string.v name in + Test { name; loc; tags; fn } + + let group ~name ~loc ~tags children = + let name = Safe_string.v name in + Group { name; loc; tags; children } type 'a t = { - escaped_name : string; - pp_name : unit Fmt.t; - tests : 'a test_case list; - (* caches computed from the library values. *) - filepaths : String_set.t; - doc : (Test_name.t, string) Hashtbl.t; + name : Safe_string.t; + loc : Lexing.position option; + tests : 'a test list; } - let v ~name = - match String.length name with - | 0 -> Error `Empty_name - | _ -> - let escaped_name = escape name in - let pp_name = Fmt.(const string) name in - let tests = [] in - let filepaths = String_set.empty in - let doc = Hashtbl.create 0 in - Ok { escaped_name; pp_name; tests; filepaths; doc } - - let name { escaped_name; _ } = escaped_name - let pp_name ppf { pp_name; _ } = pp_name ppf () - - let check_path_is_unique t tname = - match String_set.mem (Test_name.file tname) t.filepaths with - | false -> Ok () - | true -> Error (`Duplicate_test_path (Fmt.to_to_string Test_name.pp tname)) - - let add t (tname, doc, speed_level, fn) = - match check_path_is_unique t tname with - | Error _ as e -> e - | Ok () -> - let tests = { name = tname; speed_level; fn } :: t.tests in - let filepaths = String_set.add (Test_name.file tname) t.filepaths in - Hashtbl.add t.doc tname doc; - Ok { t with tests; filepaths } - - let tests t = List.rev t.tests - - let doc_of_test_name t path = - try Hashtbl.find t.doc path with Not_found -> "" + let of_tests ~name ~loc tests = + if String.is_empty name then Error `Empty_name + else + let name = Safe_string.v name in + Ok { name; loc; tests } + + let rec list_fold_until ~f ~init:acc ~finish = function + | [] -> M.return (finish acc) + | [ x ] -> ( + f ~last:true acc x >|= function Stop c -> c | Continue c -> finish c) + | x :: (_ :: _ as xs) -> ( + f ~last:false acc x >>= function + | Stop c -> M.return c + | Continue acc -> list_fold_until ~f ~init:acc ~finish xs) + + let foldi_until ~filter ?group ?test ~init:acc ~finish t = + let fold_default _ acc _ = M.return (Continue acc) in + let group = Option.value group ~default:fold_default + and test = Option.value test ~default:fold_default in + let rec aux ~last ~path acc elt = + match elt with + | Test t -> + let ctx = + object + method last = last + method path = path + method name = t.name + end + in + let arg = + match filter t.tags with `Run -> `Run t.fn | `Skip -> `Skip + in + test ctx acc arg + | Group g -> ( + let arg = filter g.tags in + let ctx = + object + method last = last + method path = path + method name = g.name + end + in + M.bind (group ctx acc arg) @@ function + | Stop _ as x -> M.return x + | Continue acc -> ( + match arg with + | `Skip -> M.return (Continue acc) + | `Run -> + let path = path @ [ g.name ] in + list_fold_until g.children ~init:acc + ~f:(fun ~last acc child -> + aux ~last ~path acc child >|= function + | Continue _ as c -> c + | Stop _ as s -> Stop s) + ~finish:(fun x -> Continue x))) + in + list_fold_until t.tests ~init:acc ~finish ~f:(aux ~path:[]) + + let fold ~filter ~group ~test ~init t = + foldi_until t ~filter ~init + ~finish:(fun x -> x) + ~group:(fun _ a x -> M.return (Continue (group a x))) + ~test:(fun _ a x -> M.return (Continue (test a x))) + + let name { name; _ } = Safe_string.to_string name + let pp_name ppf { name; _ } = Safe_string.pp ppf name + + let rec pp_files ~pre ~last_dir ppf files = + let open Fmt in + (* Only print newline at the end if our ancestors have not already done so + (i.e. we are not the descendant of a last directory *) + let pp_last_dir ppf last_dir = if not last_dir then pf ppf "@,%s" pre in + let pp_children_last ppf = + pf ppf "%s└─ %a" pre (pp_file ~last_dir:true ~pre:(pre ^ " ")) + and pp_children_not_last ppf = + pf ppf "%sβ”œβ”€ %a" pre (pp_file ~last_dir:false ~pre:(pre ^ "β”‚ ")) + in + match files with + | [] -> () + | [ last ] -> pf ppf "@,%a%a" pp_children_last last pp_last_dir last_dir + | _ :: _ :: _ -> + let last, not_last = + match List.rev files with + | [] -> assert false + | last :: not_last_rev -> (last, List.rev not_last_rev) + in + pf ppf "@,%a@,%a%a" + (list ~sep:cut pp_children_not_last) + not_last pp_children_last last pp_last_dir last_dir + + and pp_file ~pre ~last_dir ppf = + let open Fmt in + let pp_group_name = styled `Bold (styled `Blue Safe_string.pp) in + function + | Test { name; tags; _ } -> + Fmt.pf ppf "%a %a" Safe_string.pp name Fmt.(styled `Faint pp_tags) tags + | Group { name; children; _ } -> + pp_group_name ppf name; + pp_files ~pre ~last_dir ppf children + + and pp_tags ppf ts = + let open Fmt in + string ppf "< "; + list ~sep:(const string "; ") Tag.pp ppf (Tag.Set.to_list ts); + Fmt.string ppf " >" + + let pp_file ppf t = pp_file ~pre:"" ~last_dir:false ppf t + + let pp ppf t = + pp_file ppf + (Group + { name = t.name; loc = None; tags = Tag.Set.empty; children = t.tests }) end diff --git a/src/alcotest-engine/model.mli b/src/alcotest-engine/model.mli new file mode 100644 index 00000000..7a480fef --- /dev/null +++ b/src/alcotest-engine/model.mli @@ -0,0 +1,79 @@ +open Stdlib_ext + +module Run_result : sig + type index = Safe_string.t list * Safe_string.t + + type t = + | Ok + | Exn of index * string * unit Fmt.t + | Error of index * unit Fmt.t + | Skip + | Todo of string + + val is_failure : t -> bool + (** [is_failure] holds for test results that are error states. *) + + val has_run : t -> bool +end + +module Suite (M : Monad.S) : sig + type 'a test + + val test : + name:string -> + loc:Lexing.position option -> + tags:Tag.Set.t -> + ('a -> unit M.t) -> + 'a test + + val group : + name:string -> + loc:Lexing.position option -> + tags:Tag.Set.t -> + 'a test list -> + 'a test + + type 'a t + + type 'a with_context := + < path : Safe_string.t list ; name : Safe_string.t ; last : bool > -> 'a + + val foldi_until : + filter:Tag.Filter.t -> + ?group: + ('acc -> [ `Run | `Skip ] -> ('acc, 'final) continue_or_stop M.t) + with_context -> + ?test: + ('acc -> + [ `Run of 'a -> unit M.t | `Skip ] -> + ('acc, 'final) continue_or_stop M.t) + with_context -> + init:'acc -> + finish:('acc -> 'final) -> + 'a t -> + 'final M.t + (** Depth-first traversal over the suite, skipping nodes according to the + [filter] predicate defined over node {!Tag}s. *) + + val fold : + filter:Tag.Filter.t -> + group:('acc -> [ `Run | `Skip ] -> 'acc) -> + test:('acc -> [ `Run of 'a -> unit M.t | `Skip ] -> 'acc) -> + init:'acc -> + 'a t -> + 'acc M.t + + val of_tests : + name:string -> + loc:Lexing.position option -> + 'a test list -> + ('a t, [ `Empty_name ]) result + + val name : _ t -> string + (** An escaped form of the suite name. *) + + val pp_name : _ t Fmt.t + (** Pretty-print the unescaped suite name. *) + + val pp : _ t Fmt.t +end diff --git a/src/alcotest-engine/monad.ml b/src/alcotest-engine/monad.ml index 91f6c615..0cee80cd 100644 --- a/src/alcotest-engine/monad.ml +++ b/src/alcotest-engine/monad.ml @@ -27,9 +27,11 @@ end module Extend (M : S) = struct include M + let map f x = M.bind x (fun y -> M.return (f y)) + module Infix = struct let ( >>= ) = M.bind - let ( >|= ) x f = x >>= fun y -> M.return (f y) + let ( >|= ) x f = map f x end open Infix diff --git a/src/alcotest-engine/monad_intf.ml b/src/alcotest-engine/monad_intf.ml index e2c4f86d..417d5f19 100644 --- a/src/alcotest-engine/monad_intf.ml +++ b/src/alcotest-engine/monad_intf.ml @@ -22,9 +22,11 @@ module type S = sig val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t end -module type EXTENDED = sig +module type Extended = sig include S + val map : ('a -> 'b) -> 'a t -> 'b t + module Infix : sig val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t @@ -38,8 +40,8 @@ end module type Monad = sig module type S = S - module type EXTENDED = EXTENDED + module type Extended = Extended module Identity : S with type 'a t = 'a - module Extend (M : S) : EXTENDED with type 'a t = 'a M.t + module Extend (M : S) : Extended with type 'a t = 'a M.t end diff --git a/src/alcotest-engine/platform.ml b/src/alcotest-engine/platform.ml index c754e9cf..21b77db5 100644 --- a/src/alcotest-engine/platform.ml +++ b/src/alcotest-engine/platform.ml @@ -1,4 +1,7 @@ module type S = sig + val name : string + (** The name of the platform, for use in user messages. *) + val time : unit -> float (** [time ()] returns the current timestamp, used to measure the duration of a testrun. *) @@ -6,15 +9,15 @@ module type S = sig val getcwd : unit -> string (** [getcwd ()] returns the current working directory. *) - val prepare : base:string -> dir:string -> name:string -> unit - (** [prepare ~base ~dir ~name] is called before test suite execution. [base] - is the parent of the log directory, [dir] the log directory (including - unique testrun ID), and [name] is the test name. On Unix, this function - creates the log directory [dir] for the test output, and sets up the - symlink [latest] to the latest result. *) + val prepare : root:string -> uuid:string -> name:string -> unit + (** [prepare ~base ~dir ~name] is called before test suite execution. - type 'a promise - (** The type of monadic actions handled by {!with_redirect}. *) + - [root] is the log directory; + - [uuid] is the unique test execution ID; + - [name] is the suite name. + + On Unix, this function creates the log directory [dir] for the test + output, and sets up the symlink [latest] to the latest result. *) val stdout_isatty : unit -> bool (** Return [true] if standard output refers to a terminal or console window, @@ -24,11 +27,20 @@ module type S = sig (** [stdout_columns ()] is the current width of [stdout] in columns, or [None] if no width can be determined (e.g. [stdout] is not a TTY). *) - val with_redirect : string -> (unit -> 'a promise) -> 'a promise + type file_descriptor + + val mkdir_p : string -> unit + val file_exists : string -> bool + val open_ : string -> file_descriptor + val close : file_descriptor -> unit + val redirection_supported : bool + + type 'a promise + (** The type of monadic actions handled by {!with_redirect}. *) + + val with_redirect : file_descriptor -> (unit -> 'a promise) -> 'a promise (** [with_redirect output_file f] is called for each test. On Unix, it it - deals with redirection of standard streams to the [output_file]. The - implementation of [with_redirect] has to make sure to call [f] in order to - run the test case. *) + deals with redirection of standard streams to the [output_file]. *) val setup_std_outputs : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool -> unit -> unit @@ -39,4 +51,4 @@ module type S = sig (** [home_directory ()] is the current user's HOME directory, if it exists. *) end -module type MAKER = functor (M : Monad.S) -> S with type 'a promise := 'a M.t +module type MAKER = functor (M : Monad.S) -> S with type 'a promise = 'a M.t diff --git a/src/alcotest-engine/pp.ml b/src/alcotest-engine/pp.ml index 643e4856..117ea529 100644 --- a/src/alcotest-engine/pp.ml +++ b/src/alcotest-engine/pp.ml @@ -18,48 +18,73 @@ include Pp_intf include Pp_intf.Types open Model -open Utils +open Stdlib_ext -let colour_of_tag = function - | `Ok -> `Green - | `Fail -> `Red - | `Skip | `Todo | `Assert -> `Yellow +module Tag : sig + val pp : wrapped:bool -> tag Fmt.t + val colour : tag -> Fmt.style + val of_run_result : Run_result.t -> tag +end = struct + let colour = function + | `Ok -> `Green + | `Fail -> `Red + | `Skip | `Todo | `Assert -> `Yellow -let string_of_tag = function - | `Ok -> "OK" - | `Fail -> "FAIL" - | `Skip -> "SKIP" - | `Todo -> "TODO" - | `Assert -> "ASSERT" + let string_of_tag : tag -> string = function + | `Ok -> "PASS" + | `Fail -> "FAIL" + | `Skip -> "SKIP" + | `Todo -> " β€”β€” " + | `Assert -> "ASSERT" -let pp_tag ~wrapped ppf typ = - let colour = colour_of_tag typ in - let tag = string_of_tag typ in - let tag = if wrapped then "[" ^ tag ^ "]" else tag in - Fmt.(styled colour string) ppf tag + let of_run_result : Run_result.t -> tag = function + | Ok -> `Ok + | Exn _ | Error _ -> `Fail + | Skip -> `Skip + | Todo _ -> `Todo -let tag = pp_tag ~wrapped:false + let pp ~wrapped ppf typ = + let colour = colour typ in + let tag = string_of_tag typ in + let tag = if wrapped then "[" ^ tag ^ "]" else tag in + Fmt.(styled colour string) ppf tag +end + +let left_padding ~with_selector = + let open Fmt in + (if with_selector then const (styled `Bold (styled `Red char)) '>' + else const char ' ') + ++ const char ' ' + +let quoted f = Fmt.(const char '`' ++ f ++ const char '\'') +let plural ppf x = Fmt.pf ppf (if x < 2 then "" else "s") + +let user_error msg = + Fmt.epr "%a: %s\n@." Fmt.(styled `Red string) "ERROR" msg; + exit 1 -module Make (P : sig +let tag = Tag.pp ~wrapped:false + +module Width_sensitive (P : sig val stdout_columns : unit -> int option end) = struct let terminal_width = lazy (match P.stdout_columns () with Some w -> w | None -> 80) - let rresult_error ppf = function - | `Error (_, e) -> Fmt.pf ppf "%a@," e () - | `Exn (_, n, e) -> Fmt.pf ppf "[%s] @[%a@]" n e () - | `Ok | `Todo _ | `Skip -> () + let rresult_error : Run_result.t Fmt.t = + fun ppf -> function + | Error (_, e) -> Fmt.pf ppf "%a@," e () + | Exn (_, n, e) -> Fmt.pf ppf "[%s] @[%a@]" n e () + | Ok | Todo _ | Skip -> () (* Colours *) let color c ppf fmt = Fmt.(styled c string) ppf fmt let red_s fmt = color `Red fmt let red ppf fmt = Fmt.kstrf (fun str -> red_s ppf str) fmt let green_s fmt = color `Green fmt - let yellow_s fmt = color `Yellow fmt let left_gutter = 2 - let left_tag = 14 + let left_tag = 10 let left_total = left_gutter + left_tag let left nb pp ppf a = @@ -70,107 +95,108 @@ struct pp ppf a; Fmt.string ppf (String.v ~len:nb (fun _ -> ' '))) - let pp_test_name ~max_label ppf tname = - let name_len = Test_name.length tname in - let index = Test_name.index tname in - let padding = - match max_label + 8 - name_len with - | n when n <= 0 -> "" - | n -> String.v ~len:n (fun _ -> ' ') - in - Fmt.pf ppf "%a%s%3d" Fmt.(styled `Cyan Test_name.pp) tname padding index - - let info ?(available_width = Lazy.force terminal_width) ~max_label - ~doc_of_test_name ppf tname = - let pp_test_name ppf = Fmt.pf ppf "%a " (pp_test_name ~max_label) tname in - let test_doc = - let test_doc = doc_of_test_name tname in - let available_width = - pp_test_name Format.str_formatter; - let used_width = String.length_utf8 (Format.flush_str_formatter ()) in - available_width - used_width - in - if String.length_utf8 test_doc <= available_width then test_doc - else String.prefix_utf8 (available_width - 3) test_doc ^ "..." + let info ?(available_width = Lazy.force terminal_width) ppf (path, name) = + let sep = Fmt.(const (styled `Faint string) " β€Ί ") in + let sep_length = 3 in + let rec aux available_width = function + | [] -> + if available_width < Safe_string.length name then ( + Safe_string.pp ppf + (Safe_string.prefix (available_width - sep_length) name); + Fmt.string ppf "...") + else Safe_string.pp ppf name + | x :: xs -> + let len = Safe_string.length x in + if available_width < len then ( + Safe_string.pp ppf (Safe_string.prefix (available_width - 3) x); + Fmt.string ppf "...") + else ( + Fmt.styled `Faint Safe_string.pp ppf x; + sep ppf (); + aux (available_width - len - sep_length) xs) in - Fmt.pf ppf "%t%s" pp_test_name test_doc - - let tag_of_result = function - | `Ok -> `Ok - | `Exn _ | `Error _ -> `Fail - | `Skip -> `Skip - | `Todo _ -> `Todo + aux available_width path let pp_result ppf result = - let tag = tag_of_result result in - left left_tag (pp_tag ~wrapped:true) ppf tag + let tag = Tag.of_run_result result in + left left_tag (Tag.pp ~wrapped:true) ppf tag - let pp_result_compact ppf result = - let colour = result |> tag_of_result |> colour_of_tag in + let pp_result_compact : Run_result.t Fmt.t = + fun ppf result -> + let colour = result |> Tag.of_run_result |> Tag.colour in let char = match result with - | `Ok -> '.' - | `Exn _ | `Error _ -> 'F' - | `Skip -> 'S' - | `Todo _ -> 'T' + | Ok -> '.' + | Exn _ | Error _ -> 'F' + | Skip -> 'S' + | Todo _ -> 'T' in Fmt.(styled colour char) ppf char - let left_padding ~with_selector = - let open Fmt in - (if with_selector then const (styled `Bold (styled `Red char)) '>' - else const char ' ') - ++ const char ' ' - - let pp_result_full ~max_label ~doc_of_test_name ~selector_on_failure ppf - (path, result) = + let pp_result_full ~selector_on_failure ppf (path, result) = let with_selector = selector_on_failure && Run_result.is_failure result in + let available_width = Lazy.force terminal_width - left_total in (left_padding ~with_selector) ppf (); pp_result ppf result; - let available_width = Lazy.force terminal_width - left_total in - (info ~available_width ~max_label ~doc_of_test_name) ppf path; - () + info ~available_width ppf path - let event_line ~margins ~max_label ~doc_of_test_name ppf = function - | `Result (p, r) -> + let event_line ppf = function + | { index; type_ = Result r } -> pp_result ppf r; - (info - ~available_width:(Lazy.force terminal_width - margins - left_total) - ~max_label ~doc_of_test_name) - ppf p + info ppf index | _ -> assert false - let event ~isatty ~compact ~max_label ~doc_of_test_name ~selector_on_failure - ~tests_so_far ppf event = - match (compact, isatty, event) with - | true, _, `Start _ | _, false, `Start _ -> () - | false, true, `Start tname -> - Fmt.( - left_padding ~with_selector:false - ++ const (left left_tag yellow_s) "..." - ++ const - (info - ~available_width:(Lazy.force terminal_width - left_total) - ~max_label ~doc_of_test_name) - tname) - ppf () - | true, _, `Result (_, r) -> - pp_result_compact ppf r; - (* Wrap compact output to terminal width manually *) - if (tests_so_far + 1) mod Lazy.force terminal_width = 0 then - Format.pp_force_newline ppf (); - () - | false, _, `Result (tname, r) -> - if isatty then Fmt.pf ppf "\r"; - Fmt.pf ppf "%a@," - (pp_result_full ~max_label ~doc_of_test_name ~selector_on_failure) - (tname, r) + module Progress_reporter = struct + type t = { + ppf : Format.formatter; + isatty : bool; + compact : bool; + selector_on_first_failure : bool; + mutable prior_failure : bool; + mutable tests_so_far : int; + } + + let create ~ppf ~isatty ~compact ~selector_on_first_failure = + { + ppf; + isatty; + compact; + selector_on_first_failure; + prior_failure = false; + tests_so_far = 0; + } + + let event t event = + match (t.compact, t.isatty, event.type_) with + | true, _, Start | _, false, Start -> () + | false, true, Start -> + left_padding ~with_selector:false t.ppf (); + (left left_tag (Tag.pp ~wrapped:true)) t.ppf `Todo; + info + ~available_width:(Lazy.force terminal_width - left_total) + t.ppf event.index + | true, _, Result r -> + t.tests_so_far <- succ t.tests_so_far; + pp_result_compact t.ppf r; + (* Wrap compact output to terminal width manually *) + if t.tests_so_far mod Lazy.force terminal_width = 0 then + Format.pp_force_newline t.ppf (); + () + | false, _, Result r -> + if t.isatty then Fmt.char t.ppf '\r'; + pp_result_full + ~selector_on_failure: + (t.selector_on_first_failure && not t.prior_failure) + t.ppf (event.index, r); + if Run_result.is_failure r then t.prior_failure <- true; + Format.pp_force_newline t.ppf () + end let pp_suite_errors ~show_all = function | [] -> Fmt.nop | x :: _ as xs -> (if show_all then xs else [ x ]) |> Fmt.concat - let pp_plural ppf x = Fmt.pf ppf (if x < 2 then "" else "s") + let plural ppf x = Fmt.pf ppf (if x < 2 then "" else "s") let quoted f = Fmt.(const char '`' ++ f ++ const char '\'') let with_surrounding_box (type a) (f : a Fmt.t) : a Fmt.t = @@ -208,12 +234,12 @@ struct let pp_summary ppf r = let pp_failures ppf = function | 0 -> green_s ppf "Test Successful" - | n -> red ppf "%d failure%a!" n pp_plural n + | n -> red ppf "%d failure%a!" n plural n in - Fmt.pf ppf "%a in %.3fs. %d test%a run.@," pp_failures r.failures r.time - r.success pp_plural r.success + Fmt.pf ppf "%a in %.3fs. %d test%a run.@,\n" pp_failures r.failures r.time + r.success plural r.success - let suite_results ~log_dir cfg ppf r = + let suite_results cfg ppf r = let print_summary = (not cfg#compact) || r.failures > 0 in match cfg#json with | true -> @@ -232,11 +258,7 @@ struct (pp_suite_errors ~show_all:(cfg#verbose || cfg#show_errors) r.errors) ppf (); if print_summary then ( - if not cfg#verbose then pp_full_logs ppf log_dir; + if not cfg#verbose then pp_full_logs ppf cfg#root_log_capture_dir; pp_summary ppf r); Format.pp_close_box ppf () - - let user_error msg = - Fmt.epr "%a: %s\n" Fmt.(styled `Red string) "ERROR" msg; - exit 1 end diff --git a/src/alcotest-engine/pp_intf.ml b/src/alcotest-engine/pp_intf.ml index 6dc0a6bd..16757a7a 100644 --- a/src/alcotest-engine/pp_intf.ml +++ b/src/alcotest-engine/pp_intf.ml @@ -16,9 +16,12 @@ *) open Model +open Stdlib_ext module Types = struct - type event = [ `Result of Test_name.t * Run_result.t | `Start of Test_name.t ] + type index = Safe_string.t list * Safe_string.t + type event_type = Start | Result of Run_result.t + type event = { index : index; type_ : event_type } type result = { success : int; @@ -26,43 +29,41 @@ module Types = struct time : float; errors : unit Fmt.t list; } + + type tag = [ `Ok | `Fail | `Skip | `Todo | `Assert ] end -module type S = sig +module type Width_sensitive = sig + type index type event type result - val info : - ?available_width:int -> - max_label:int -> - doc_of_test_name:(Test_name.t -> string) -> - Test_name.t Fmt.t - + val info : ?available_width:int -> index Fmt.t val rresult_error : Run_result.t Fmt.t + val event_line : event Fmt.t + + module Progress_reporter : sig + type t - val event_line : - margins:int -> - max_label:int -> - doc_of_test_name:(Test_name.t -> string) -> - [ `Result of Test_name.t * [< Run_result.t ] | `Start of Test_name.t ] Fmt.t - - val event : - isatty:bool -> - compact:bool -> - max_label:int -> - doc_of_test_name:(Test_name.t -> string) -> - selector_on_failure:bool -> - tests_so_far:int -> - event Fmt.t + val create : + ppf:Format.formatter -> + isatty:bool -> + compact:bool -> + selector_on_first_failure:bool -> + t + + val event : t -> event -> unit + end val suite_results : - log_dir:string -> - < verbose : bool ; show_errors : bool ; json : bool ; compact : bool ; .. > -> + < verbose : bool + ; show_errors : bool + ; json : bool + ; compact : bool + ; root_log_capture_dir : string + ; .. > -> result Fmt.t - val quoted : 'a Fmt.t -> 'a Fmt.t - (** Wraps a formatter with `GNU-style quotation marks'. *) - val with_surrounding_box : 'a Fmt.t -> 'a Fmt.t (** Wraps a formatter with a Unicode box with width given by {!terminal_width}. Uses box-drawing characters from code page 437. *) @@ -70,8 +71,17 @@ module type S = sig val horizontal_rule : _ Fmt.t (** Horizontal rule of length {!terminal_width}. Uses box-drawing characters from code page 437. *) +end + +module type Pp = sig + include module type of Types - val pp_plural : int Fmt.t + val tag : tag Fmt.t + + val quoted : 'a Fmt.t -> 'a Fmt.t + (** Wraps a formatter with GNU-style `quotation marks'. *) + + val plural : int Fmt.t (** This is for adding an 's' to words that should be pluralized, e.g. {[ @@ -81,17 +91,12 @@ module type S = sig val user_error : string -> _ (** Raise a user error, then fail. *) -end - -module type Make_arg = sig - val stdout_columns : unit -> int option -end - -module type Pp = sig - include module type of Types - - val tag : [ `Ok | `Fail | `Skip | `Todo | `Assert ] Fmt.t - module Make (X : Make_arg) : - S with type event := event and type result := result + module Width_sensitive (_ : sig + val stdout_columns : unit -> int option + end) : + Width_sensitive + with type index := index + and type event := event + and type result := result end diff --git a/src/alcotest-engine/source_code_position.ml b/src/alcotest-engine/source_code_position.ml new file mode 100644 index 00000000..bdf6a6fa --- /dev/null +++ b/src/alcotest-engine/source_code_position.ml @@ -0,0 +1,2 @@ +type here = Lexing.position +type pos = string * int * int * int diff --git a/src/alcotest-engine/stdlib_ext.ml b/src/alcotest-engine/stdlib_ext.ml new file mode 100644 index 00000000..355b837b --- /dev/null +++ b/src/alcotest-engine/stdlib_ext.ml @@ -0,0 +1,163 @@ +let ( >> ) f g x = x |> f |> g + +type ('a, 'b) continue_or_stop = Continue of 'a | Stop of 'b + +module Fun = struct + let const x _ = x +end + +module Int = struct + module T = struct + type t = int + + let compare = (compare : int -> int -> int) + end + + include T + module Set = Set.Make (T) +end + +module Option = struct + type 'a t = 'a option + + module Infix = struct + let ( >>= ) x f = match x with None -> None | Some x -> f x + let ( >>| ) x f = match x with None -> None | Some x -> Some (f x) + end + + let ( || ) a b = + match (a, b) with + | None, None -> None + | (Some _ as x), _ | None, (Some _ as x) -> x + + let is_some = function Some _ -> true | None -> false + + let get_exn = function + | Some x -> x + | None -> invalid_arg "Option.get_exn: None" + + let value ~default = function Some x -> x | None -> default + let value_lazy ~default = function Some x -> x | None -> Lazy.force default +end + +module String = struct + include Astring.String + + let length_utf8 = Uutf.String.fold_utf_8 (fun count _ _ -> count + 1) 0 + + let prefix_utf8 uchars string = + let exception Found_new_length of int in + try + let (_ : int) = + Uutf.String.fold_utf_8 + (fun count start_pos _ -> + if count = uchars then raise (Found_new_length start_pos) + else count + 1) + 0 string + in + string + with Found_new_length l -> String.sub string 0 l +end + +module Safe_string = struct + let escape str = + let add_codepoint buf uchar = + Uchar.to_int uchar |> Fmt.str "U+%04X" |> Buffer.add_string buf + in + let buf = Buffer.create (String.length str * 2) in + let get_normalized_char _ _ u = + match u with + | `Uchar u -> + if Uchar.is_char u then + match Uchar.to_char u with + | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-' | ' ' | '.') as + c -> + Buffer.add_char buf c + | _ -> add_codepoint buf u + else add_codepoint buf u + | `Malformed _ -> Uutf.Buffer.add_utf_8 buf Uutf.u_rep + in + Uutf.String.fold_utf_8 get_normalized_char () str; + Buffer.contents buf + + type t = { raw : string; escaped : string } + + let v raw = { raw; escaped = escape raw } + let to_string { escaped; _ } = escaped + let pp = Fmt.using (fun { raw; _ } -> raw) Fmt.string + let length { raw; _ } = String.length_utf8 raw + let prefix n { raw; _ } = v (String.prefix_utf8 n raw) + let equal t t' = String.equal t.raw t'.raw + let compare t t' = String.compare t.raw t'.raw +end + +module List = struct + include List + + type 'a t = 'a list + + let filter_map f l = + let rec inner acc = function + | [] -> rev acc + | x :: xs -> ( + match f x with + | None -> (inner [@tailcall]) acc xs + | Some y -> (inner [@tailcall]) (y :: acc) xs) + in + inner [] l + + let lift_result l = + List.fold_right + (fun a b -> + match (a, b) with + | Ok o, Ok acc -> Ok (o :: acc) + | Ok _, Error e -> Error e + | Error e, Error acc -> Error (e :: acc) + | Error e, Ok _ -> Error [ e ]) + l (Ok []) + + let rev_take = + let rec aux acc n l = + match l with + | x :: xs -> if n > 0 then aux (x :: acc) (n - 1) xs else acc + | [] -> acc + in + fun n l -> aux [] n l + + let init n f = + let rec aux acc i = if i >= n then rev acc else aux (f i :: acc) (i + 1) in + aux [] 0 +end + +module Result = struct + let map f = function Ok x -> Ok (f x) | Error e -> Error e + let ok_or_failwith = function Ok x -> x | Error (`Msg m) -> failwith m +end + +module Cmdliner_syntax = struct + open Cmdliner + + let ( let+ ) t f = Term.(const f $ t) + let ( and+ ) a b = Term.(const (fun x y -> (x, y)) $ a $ b) + let ( >>| ) x f = Term.(app (const f) x) +end + +type ('a, 'f) app + +module Higher = struct + module Make1 (T : sig + type 'a t + end) = + struct + type 'a t = 'a T.t + type br + + external inj : 'a t -> ('a, br) app = "%identity" + external prj : ('a, br) app -> 'a t = "%identity" + end +end + +type 'm monad = { + return : 'a. 'a -> ('a, 'm) app; + bind : 'a 'b. ('a, 'm) app -> ('a -> ('b, 'm) app) -> ('b, 'm) app; +} diff --git a/src/alcotest-engine/stdlib_ext.mli b/src/alcotest-engine/stdlib_ext.mli new file mode 100644 index 00000000..15255d62 --- /dev/null +++ b/src/alcotest-engine/stdlib_ext.mli @@ -0,0 +1,117 @@ +(** This module defines extensions and backports for the minimal supported + version of the OCaml standard library, for use in Alcotest and its various + backends. + + It does not provide a stable interface. *) + +val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c +(** Left-to-right function composition. *) + +module Fun : sig + val const : 'a -> 'b -> 'a +end + +module Int : sig + type t = int + + val compare : t -> t -> int + + module Set : Stdlib.Set.S with type elt = t +end + +module Option : sig + type 'a t = 'a option + + module Infix : sig + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t + val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t + end + + val ( || ) : 'a option -> 'a option -> 'a option + val get_exn : 'a t -> 'a + val is_some : 'a t -> bool + val value : default:'a -> 'a t -> 'a + val value_lazy : default:'a Lazy.t -> 'a t -> 'a +end + +module String : sig + include module type of Astring.String + + val length_utf8 : string -> int + (** Get the length of a string in UTF-8 characters and malformed segments. *) + + val prefix_utf8 : int -> string -> string + (** [prefix_utf8 n s] is the prefix of [s] containing [n] UTF-8 characters (or + [s] if it contains fewer than [n] UTF-8 characters). *) +end + +(** A UTF-8 encoded string that has been made safe for use in filesystems by + escaping any "unsafe" characters as their [U+XXXX] notational form. *) +module Safe_string : sig + type t + + val v : string -> t + + val to_string : t -> string + (** Get the escaped form of the given {!Safe_string}. *) + + val pp : t Fmt.t + (** Pretty-print the unescaped string. *) + + val length : t -> int + (** The approximate number of terminal columns consumed by [pp_name]. *) + + val prefix : int -> t -> t + (** Truncate a string to a given number of terminal columns. *) + + val equal : t -> t -> bool + val compare : t -> t -> int +end + +module List : sig + include module type of List + + type 'a t = 'a list + + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + val lift_result : ('a, 'b) result t -> ('a t, 'b t) result + + val rev_take : int -> 'a list -> 'a list + (** Reverse a list [l], taking at most [n] elements from [l]. *) + + val init : int -> (int -> 'a) -> 'a list +end + +module Result : sig + val map : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result + val ok_or_failwith : ('a, [ `Msg of string ]) result -> 'a +end + +module Cmdliner_syntax : sig + open Cmdliner + + val ( let+ ) : 'a Term.t -> ('a -> 'b) -> 'b Term.t + val ( and+ ) : 'a Term.t -> 'b Term.t -> ('a * 'b) Term.t + val ( >>| ) : 'a Term.t -> ('a -> 'b) -> 'b Term.t +end + +type ('a, 'b) continue_or_stop = Continue of 'a | Stop of 'b +type ('a, 'f) app + +module Higher : sig + module Make1 (T : sig + type 'a t + end) : sig + type 'a t + type br + + val inj : 'a t -> ('a, br) app + val prj : ('a, br) app -> 'a t + end + with type 'a t := 'a T.t +end + +type 'm monad = { + return : 'a. 'a -> ('a, 'm) app; + bind : 'a 'b. ('a, 'm) app -> ('a -> ('b, 'm) app) -> ('b, 'm) app; +} diff --git a/src/alcotest-engine/tag.ml b/src/alcotest-engine/tag.ml new file mode 100644 index 00000000..5188357e --- /dev/null +++ b/src/alcotest-engine/tag.ml @@ -0,0 +1,112 @@ +open Stdlib_ext + +(** A universal type, into which any other type can be injected and (partially) + recovered. *) +module Univ : sig + type t + + val create : unit -> ('a -> t) * (t -> 'a option) +end = struct + type t = .. + + let create : type a. unit -> (a -> t) * (t -> a option) = + fun () -> + let module M = struct + type t += Case of a option + end in + ((fun x -> M.Case (Some x)), function M.Case x -> x | _ -> None) +end + +type 'a spec = { + witness : 'a Witness.t; + id : int; + inj : 'a -> Univ.t; + prj : Univ.t -> 'a option; + name : string; + pp : Format.formatter -> 'a -> unit; +} + +let gen_id = + let counter = ref (-1) in + fun () -> + incr counter; + !counter + +let spec ~name ~pp = + let inj, prj = Univ.create () in + { witness = Witness.create (); id = gen_id (); inj; prj; name; pp } + +type t = V : 'a spec * 'a -> t + +let pp ppf (V ({ name; pp; _ }, v)) = Fmt.pf ppf "%s = %a" name pp v +let pp_spec ppf spec = Format.fprintf ppf "(spec %s)" spec.name +let const ~name v = V (spec ~name ~pp:Fmt.(const string name), v) + +module Set = struct + (** A tag set is a map from (boxed) definitions to tags. *) + + module Key = struct + type t = V : 'a spec -> t [@@ocaml.unboxed] + + let compare (V x) (V y) = Int.compare x.id y.id + end + + module Map = Map.Make (Key) + + type nonrec t = t Map.t + + let empty = Map.empty + let add (V (k, _) as v) s = Map.add (Key.V k) v s + + let find : type a. a spec -> t -> a option = + fun k t -> + try + let (V (k', v)) = Map.find (Key.V k) t in + match Witness.eq k.witness k'.witness with + | Some Refl -> Some v + | None -> assert false + with Not_found -> None + + let to_list = Map.to_seq >> List.of_seq >> List.map snd + + let fold_until = + let rec aux ~f ~finish acc seq = + match seq () with + | Seq.Cons ((_k, v), xf) -> ( + match f acc v with + | Continue acc -> aux ~f ~finish acc xf + | Stop final -> final) + | Seq.Nil -> finish acc + in + fun t ~init ~f ~finish -> aux ~f ~finish init (Map.to_seq t) +end + +module Speed_level = struct + type t = [ `Quick | `Slow ] + + let tag = + spec ~name:"speed_level" + ~pp:(Fmt.of_to_string (function `Quick -> "Quick" | `Slow -> "Slow")) + + let quick = V (tag, `Quick) + let slow = V (tag, `Slow) + + let without_slow s = + match Set.find tag s with Some `Slow -> `Skip | _ -> `Run +end + +module Predicate = struct + type t = unit -> [ `Run | `Skip ] + + let tag = + spec ~name:"Predicate" ~pp:(fun ppf _ -> Fmt.pf ppf "Predicate <...>") + + let only_if s = match Set.find tag s with Some p -> p () | None -> `Run +end + +module Filter = struct + type t = Set.t -> [ `Run | `Skip ] + + let ( ++ ) f g x = match (f x, g x) with `Run, `Run -> `Run | _, _ -> `Skip + let default = Speed_level.without_slow ++ Predicate.only_if +end diff --git a/src/alcotest-engine/tag.mli b/src/alcotest-engine/tag.mli new file mode 100644 index 00000000..87304831 --- /dev/null +++ b/src/alcotest-engine/tag.mli @@ -0,0 +1,57 @@ +open Stdlib_ext + +type 'a spec + +val spec : name:string -> pp:(Format.formatter -> 'a -> unit) -> 'a spec + +type t = V : 'a spec * 'a -> t + +val pp : t Fmt.t +val pp_spec : _ spec Fmt.t +val const : name:string -> 'a -> t + +module Set : sig + type tag + type t + + val empty : t + val add : tag -> t -> t + val find : 'a spec -> t -> 'a option + val to_list : t -> tag list + + val fold_until : + t -> + init:'a -> + f:('a -> tag -> ('a, 'b) continue_or_stop) -> + finish:('a -> 'b) -> + 'b +end +with type tag := t + +module Filter : sig + type t = Set.t -> [ `Run | `Skip ] + + val ( ++ ) : t -> t -> t + (** [f ++ g] is the filter that runs only tests that are run by both [f] + {i and} [g]. *) + + val default : t +end + +module Speed_level : sig + type tag + type t = [ `Quick | `Slow ] + + val tag : t spec + val quick : tag + val slow : tag + val without_slow : Filter.t +end +with type tag := t + +module Predicate : sig + type t = unit -> [ `Run | `Skip ] + + val tag : t spec + val only_if : Filter.t +end diff --git a/src/alcotest-engine/test.mli b/src/alcotest-engine/test.mli index e473c3ff..14b09fa6 100644 --- a/src/alcotest-engine/test.mli +++ b/src/alcotest-engine/test.mli @@ -14,11 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(** {1 Testable values} - - The following combinators represent types that can be used with the {!check} - functions below. *) - (** [TESTABLE] provides an abstract description for testable values. *) module type TESTABLE = sig type t @@ -112,17 +107,6 @@ val neg : 'a testable -> 'a testable Functions for asserting various properties within unit-tests. A failing assertion will cause the testcase to fail immediately. *) -module Source_code_position : sig - type here = Lexing.position - (** Location information passed via a [~here] argument, intended for use with - a PPX such as {{:https://github.com/janestreet/ppx_here} [ppx_here]}. *) - - type pos = string * int * int * int - (** Location information passed via a [~pos] argument, intended for use with - the [__POS__] macro provided by the standard library. See the - documentation of [__POS__] for more information. *) -end - type 'a extra_info = ?here:Source_code_position.here -> ?pos:Source_code_position.pos -> 'a (** The assertion functions optionally take information about the {i location} diff --git a/src/alcotest-engine/utils.ml b/src/alcotest-engine/utils.ml deleted file mode 100644 index ecd131d1..00000000 --- a/src/alcotest-engine/utils.ml +++ /dev/null @@ -1,77 +0,0 @@ -let ( >> ) f g x = x |> f |> g - -module String = struct - include Astring.String - - let length_utf8 = Uutf.String.fold_utf_8 (fun count _ _ -> count + 1) 0 - - let prefix_utf8 uchars string = - let exception Found_new_length of int in - try - let (_ : int) = - Uutf.String.fold_utf_8 - (fun count start_pos _ -> - if count = uchars then raise (Found_new_length start_pos) - else count + 1) - 0 string - in - string - with Found_new_length l -> String.sub string 0 l -end - -module List = struct - include List - - type 'a t = 'a list - - let filter_map f l = - let rec inner acc = function - | [] -> rev acc - | x :: xs -> ( - match f x with - | None -> (inner [@tailcall]) acc xs - | Some y -> (inner [@tailcall]) (y :: acc) xs) - in - inner [] l - - let lift_result l = - List.fold_right - (fun a b -> - match (a, b) with - | Ok o, Ok acc -> Ok (o :: acc) - | Ok _, Error e -> Error e - | Error e, Error acc -> Error (e :: acc) - | Error e, Ok _ -> Error [ e ]) - l (Ok []) - - let init n f = - let rec aux acc i = if i >= n then rev acc else aux (f i :: acc) (i + 1) in - aux [] 0 -end - -module Result = struct - let map f = function Ok x -> Ok (f x) | Error e -> Error e -end - -module Option = struct - let is_some = function Some _ -> true | None -> false - - let get_exn = function - | Some x -> x - | None -> invalid_arg "Option.get_exn: None" - - let value ~default = function None -> default | Some x -> x - - let ( || ) a b = - match (a, b) with - | None, None -> None - | (Some _ as x), _ | None, (Some _ as x) -> x -end - -module Cmdliner_syntax = struct - open Cmdliner - - let ( let+ ) t f = Term.(const f $ t) - let ( and+ ) a b = Term.(const (fun x y -> (x, y)) $ a $ b) - let ( >>| ) x f = Term.(app (const f) x) -end diff --git a/src/alcotest-engine/utils.mli b/src/alcotest-engine/utils.mli deleted file mode 100644 index a8d84a20..00000000 --- a/src/alcotest-engine/utils.mli +++ /dev/null @@ -1,41 +0,0 @@ -val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c - -module String : sig - include module type of Astring.String - - val length_utf8 : string -> int - (** Get the length of a string in UTF-8 characters and malformed segments. *) - - val prefix_utf8 : int -> string -> string - (** [prefix_utf8 n s] is the prefix of [s] containing [n] UTF-8 characters (or - [s] if it contains fewer than [n] UTF-8 characters). *) -end - -module List : sig - include module type of List - - type 'a t = 'a list - - val filter_map : ('a -> 'b option) -> 'a list -> 'b list - val lift_result : ('a, 'b) result t -> ('a t, 'b t) result - val init : int -> (int -> 'a) -> 'a list -end - -module Result : sig - val map : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result -end - -module Option : sig - val is_some : _ option -> bool - val get_exn : 'a option -> 'a - val value : default:'a -> 'a option -> 'a - val ( || ) : 'a option -> 'a option -> 'a option -end - -module Cmdliner_syntax : sig - open Cmdliner - - val ( let+ ) : 'a Term.t -> ('a -> 'b) -> 'b Term.t - val ( and+ ) : 'a Term.t -> 'b Term.t -> ('a * 'b) Term.t - val ( >>| ) : 'a Term.t -> ('a -> 'b) -> 'b Term.t -end diff --git a/src/alcotest-engine/witness.ml b/src/alcotest-engine/witness.ml new file mode 100644 index 00000000..00cdedc8 --- /dev/null +++ b/src/alcotest-engine/witness.ml @@ -0,0 +1,23 @@ +type (_, _) eq = Refl : ('a, 'a) eq +type _ equality = .. + +module type Inst = sig + type t + type _ equality += Eq : t equality +end + +type 'a t = (module Inst with type t = 'a) + +let create : type a. unit -> a t = + fun () -> + let module Inst = struct + type t = a + type _ equality += Eq : t equality + end in + (module Inst) + +let eq : type a b. a t -> b t -> (a, b) eq option = + fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None + +let cast : type a b. a t -> b t -> a -> b option = + fun awit bwit a -> match eq awit bwit with Some Refl -> Some a | None -> None diff --git a/src/alcotest-engine/witness.mli b/src/alcotest-engine/witness.mli new file mode 100644 index 00000000..207cca0b --- /dev/null +++ b/src/alcotest-engine/witness.mli @@ -0,0 +1,6 @@ +type 'a t +type (_, _) eq = Refl : ('a, 'a) eq + +val create : unit -> 'a t +val eq : 'a t -> 'b t -> ('a, 'b) eq option +val cast : 'a t -> 'b t -> 'a -> 'b option diff --git a/src/alcotest-lwt/alcotest_lwt.ml b/src/alcotest-lwt/alcotest_lwt.ml index 815d1a1a..d40e4b45 100644 --- a/src/alcotest-lwt/alcotest_lwt.ml +++ b/src/alcotest-lwt/alcotest_lwt.ml @@ -17,8 +17,6 @@ module Tester = Alcotest_engine.Cli.Make (Alcotest.Unix) (Lwt) include Tester -let test_case_sync n s f = test_case n s (fun x -> Lwt.return (f x)) - let run_test fn args = let async_ex, async_waker = Lwt.wait () in let handle_exn ex = @@ -28,4 +26,15 @@ let run_test fn args = Lwt.async_exception_hook := handle_exn; Lwt_switch.with_switch (fun sw -> Lwt.pick [ fn sw args; async_ex ]) -let test_case n s f = test_case n s (run_test f) +let test_sync ?here ?tag ?tags ~name f = + test ?here ?tag ?tags ~name (fun x -> Lwt.return (f x)) + +let test ?here ?tag ?tags ~name f = test ?here ?tag ?tags ~name (run_test f) + +module V1 = struct + module Tester = Alcotest_engine.Cli.Make_v1 (Alcotest.Unix) (Lwt) + include Tester + + let test_case_sync n s f = test_case n s (fun x -> Lwt.return (f x)) + let test_case n s f = test_case n s (run_test f) +end diff --git a/src/alcotest-lwt/alcotest_lwt.mli b/src/alcotest-lwt/alcotest_lwt.mli index 355c3423..7b05e87e 100644 --- a/src/alcotest-lwt/alcotest_lwt.mli +++ b/src/alcotest-lwt/alcotest_lwt.mli @@ -18,13 +18,21 @@ returns a promise that runs the tests when scheduled, catching any asynchronous exceptions thrown by the tests. *) -include Alcotest_engine.Cli.S with type return = unit Lwt.t +include + Alcotest_engine.Cli.S + with type 'a m := 'a Lwt.t + and type 'a test_args := Lwt_switch.t -> 'a + and type config := Alcotest_engine.Config.User.t + and type tag := Alcotest.Tag.t + and type tag_set := Alcotest.Tag.Set.t -val test_case : - string -> - Alcotest.speed_level -> - (Lwt_switch.t -> 'a -> unit Lwt.t) -> - 'a test_case +val test_sync : (('a -> unit) -> 'a test) Alcotest_engine.Core.identified -val test_case_sync : - string -> Alcotest.speed_level -> ('a -> unit) -> 'a test_case +module V1 : sig + include Alcotest_engine.Cli.V1 with type return = unit Lwt.t + + val test_case : + string -> speed_level -> (Lwt_switch.t -> 'a -> unit Lwt.t) -> 'a test_case + + val test_case_sync : string -> speed_level -> ('a -> unit) -> 'a test_case +end diff --git a/src/alcotest-mirage/alcotest_mirage.ml b/src/alcotest-mirage/alcotest_mirage.ml index ac064414..d9c37c52 100644 --- a/src/alcotest-mirage/alcotest_mirage.ml +++ b/src/alcotest-mirage/alcotest_mirage.ml @@ -1,30 +1,50 @@ -module Make (C : Mirage_clock.MCLOCK) = struct - module Platform (M : Alcotest_engine.Monad.S) = struct - let time () = Duration.to_f @@ C.elapsed_ns () - let getcwd () = "" - let prepare ~base:_ ~dir:_ ~name:_ = () - let stdout_isatty () = true - let stdout_columns () = None - let with_redirect _ fn = fn () - let setup_std_outputs ?style_renderer:_ ?utf_8:_ () = () - - let home_directory () = - Error (`Msg "Home directory not available for the MirageOS platform") - end +module Platform (C : Mirage_clock.MCLOCK) (M : Alcotest_engine.Monad.S) = struct + let name = "Mirage" + let time () = Duration.to_f @@ C.elapsed_ns () + let getcwd () = "" + let prepare ~root:_ ~uuid:_ ~name:_ = () + let stdout_columns () = None + let with_redirect _ fn = fn () + let mkdir_p _ = () + let stdout_isatty () = true + + type file_descriptor = unit + + let file_exists _ = false + let open_ _ = () + let close () = () + let redirection_supported = false + let setup_std_outputs ?style_renderer:_ ?utf_8:_ () = () + + let home_directory () = + Error (`Msg "Home directory not available for the MirageOS platform") +end - module Tester = Alcotest_engine.Cli.Make (Platform) (Lwt) +let run_test fn args = + let async_ex, async_waker = Lwt.wait () in + let handle_exn ex = + Logs.debug (fun f -> f "Uncaught async exception: %a" Fmt.exn ex); + if Lwt.state async_ex = Lwt.Sleep then Lwt.wakeup_exn async_waker ex + in + Lwt.async_exception_hook := handle_exn; + Lwt_switch.with_switch (fun sw -> Lwt.pick [ fn sw args; async_ex ]) + +module Make (C : Mirage_clock.MCLOCK) = struct + module Tester = Alcotest_engine.Cli.Make (Platform (C)) (Lwt) include Tester - let test_case_sync n s f = test_case n s (fun x -> Lwt.return (f x)) + let test_sync ?here ?tag ?tags ~name fn = + test ~name ?here ?tag ?tags (fun x -> Lwt.return (fn x)) - let run_test fn args = - let async_ex, async_waker = Lwt.wait () in - let handle_exn ex = - Logs.debug (fun f -> f "Uncaught async exception: %a" Fmt.exn ex); - if Lwt.state async_ex = Lwt.Sleep then Lwt.wakeup_exn async_waker ex - in - Lwt.async_exception_hook := handle_exn; - Lwt_switch.with_switch (fun sw -> Lwt.pick [ fn sw args; async_ex ]) + let test ?here ?tag ?tags ~name fn = test ~name ?here ?tag ?tags (run_test fn) +end - let test_case n s f = test_case n s (run_test f) +module V1 = struct + module Make (C : Mirage_clock.MCLOCK) = struct + module Tester = Alcotest_engine.Cli.Make_v1 (Platform (C)) (Lwt) + include Tester + + let test_case_sync n s f = test_case n s (fun x -> Lwt.return (f x)) + let test_case n s f = test_case n s (run_test f) + end end diff --git a/src/alcotest-mirage/alcotest_mirage.mli b/src/alcotest-mirage/alcotest_mirage.mli index 5c10f467..8f698166 100644 --- a/src/alcotest-mirage/alcotest_mirage.mli +++ b/src/alcotest-mirage/alcotest_mirage.mli @@ -23,10 +23,27 @@ test output to the console. *) module Make (C : Mirage_clock.MCLOCK) : sig - include Alcotest_engine.Cli.S with type return = unit Lwt.t + include + Alcotest_engine.Cli.S + with type 'a m := 'a Lwt.t + and type 'a test_args := Lwt_switch.t -> 'a + and type config := Alcotest_engine.Config.t + and type tag := Alcotest_engine.Tag.t + and type tag_set := Alcotest_engine.Tag.Set.t - val test_case : - string -> speed_level -> (Lwt_switch.t -> 'a -> unit Lwt.t) -> 'a test_case + val test_sync : (('a -> unit) -> 'a test) Alcotest_engine.Core.identified +end + +module V1 : sig + module Make (C : Mirage_clock.MCLOCK) : sig + include Alcotest_engine.Cli.V1 with type return = unit Lwt.t + + val test_case : + string -> + speed_level -> + (Lwt_switch.t -> 'a -> unit Lwt.t) -> + 'a test_case - val test_case_sync : string -> speed_level -> ('a -> unit) -> 'a test_case + val test_case_sync : string -> speed_level -> ('a -> unit) -> 'a test_case + end end diff --git a/src/alcotest/alcotest.ml b/src/alcotest/alcotest.ml index 163714a4..16f94e9d 100644 --- a/src/alcotest/alcotest.ml +++ b/src/alcotest/alcotest.ml @@ -1,8 +1,21 @@ include Alcotest_engine.Test +module Source_code_position = Alcotest_engine.Source_code_position +module Tag = Alcotest_engine.Tag + +module Config = struct + include Alcotest_engine.Config.User + + let v = create + let merge = ( || ) +end module Unix (M : Alcotest_engine.Monad.S) = struct module M = Alcotest_engine.Monad.Extend (M) + type 'a promise = 'a M.t + + let name = "Unix" + module Unix = struct open Astring include Unix @@ -32,6 +45,7 @@ module Unix (M : Alcotest_engine.Monad.S) = struct open M.Infix let time = Unix.gettimeofday + let mkdir_p path = Unix.mkdir_p path 0o770 let getcwd = Sys.getcwd let unlink_if_exists file = @@ -59,12 +73,13 @@ module Unix (M : Alcotest_engine.Monad.S) = struct in inner ~retries:0 - let prepare ~base ~dir ~name = + let prepare ~root ~uuid ~name = + let dir = Filename.concat root uuid in if not (Sys.file_exists dir) then ( Unix.mkdir_p dir 0o770; if Sys.unix || Sys.cygwin then ( - let this_exe = Filename.concat base name - and latest = Filename.concat base "latest" in + let this_exe = Filename.concat root name + and latest = Filename.concat root "latest" in unlink_if_exists this_exe; unlink_if_exists latest; symlink ~to_dir:true ~target:dir ~link_name:this_exe; @@ -81,7 +96,14 @@ module Unix (M : Alcotest_engine.Monad.S) = struct | Some { columns; _ } -> Some columns | None -> None - let with_redirect file fn = + type file_descriptor = Unix.file_descr + + let file_exists = Sys.file_exists + let open_ x = Unix.(openfile x [ O_WRONLY; O_TRUNC; O_CREAT ] 0o660) + let close = Unix.close + let redirection_supported = true + + let with_redirect fd_file fn = M.return () >>= fun () -> Fmt.(flush stdout) (); Fmt.(flush stderr) (); @@ -89,10 +111,8 @@ module Unix (M : Alcotest_engine.Monad.S) = struct let fd_stderr = Unix.descr_of_out_channel stderr in let fd_old_stdout = Unix.dup fd_stdout in let fd_old_stderr = Unix.dup fd_stderr in - let fd_file = Unix.(openfile file [ O_WRONLY; O_TRUNC; O_CREAT ] 0o660) in Unix.dup2 fd_file fd_stdout; Unix.dup2 fd_file fd_stderr; - Unix.close fd_file; (try fn () >|= fun o -> `Ok o with e -> M.return @@ `Error e) >|= fun r -> Fmt.(flush stdout ()); Fmt.(flush stderr ()); @@ -121,6 +141,12 @@ end module T = Alcotest_engine.Cli.Make (Unix) (Alcotest_engine.Monad.Identity) include T +module V1 = struct + module T = Alcotest_engine.Cli.Make_v1 (Unix) (Alcotest_engine.Monad.Identity) + include T + include Alcotest_engine.Test +end + module Core = struct module Make = Alcotest_engine.Core.Make (Unix) end diff --git a/src/alcotest/alcotest.mli b/src/alcotest/alcotest.mli index dab34b9d..7568edad 100644 --- a/src/alcotest/alcotest.mli +++ b/src/alcotest/alcotest.mli @@ -17,9 +17,13 @@ (** A lightweight and colourful test framework. [Alcotest] provides a simple interface to perform unit tests. It exposes a - simple {{!TESTABLE} TESTABLE} module type, a {{!check} check function} to - assert test predicates and a {{!run} run} function to perform a list of - [unit -> unit] test callbacks. + simple {!TESTABLE} module type, a {{!check} check function} to assert test + predicates and a {{!run} run} function to perform a list of [unit -> unit] + test callbacks. + + - {{!define} defining} a test suite; + - asserting test properties; + - running the suite. From these descriptions, [Alcotest] builds a quiet and colorful output where only faulty runs are fully displayed at the end of the run (with the full @@ -27,10 +31,78 @@ {e Release %%VERSION%%} *) -include Alcotest_engine.Cli.S with type return = unit +module Source_code_position : sig + type here = Lexing.position + (** Location information passed via a [~here] argument, intended for use with + a PPX such as {{:https://github.com/janestreet/ppx_here} [ppx_here]}. *) + + type pos = string * int * int * int + (** Location information passed via a [~pos] argument, intended for use with + the [__POS__] macro provided by the standard library. See the + documentation of [__POS__] for more information. *) +end + +module Tag : sig + include module type of Alcotest_engine.Tag with type t = Alcotest_engine.Tag.t + (** @inline *) +end + +module Config : sig + type t + + val v : + ?and_exit:bool -> + ?verbose:bool -> + ?compact:bool -> + ?tail_errors:[ `Unlimited | `Limit of int ] -> + ?quick_only:bool -> + ?show_errors:bool -> + ?json:bool -> + ?filter:Tag.Filter.t -> + ?bail:bool -> + ?log_dir:string -> + unit -> + t + + (** The various options taken by the tests runners {!run} and + {!run_with_args}: + + - [and_exit] (default [true]). Once the tests have completed, exit with + return code [0] if all tests passed, otherwise [1]. + - [verbose] (default [false]). Display the test std.out and std.err + (rather than redirecting to a log file). + - [compact] (default [false]). Compact the output of the tests. + - [tail_errors] (default unlimited). Show only the last N lines of output + of failed tests. + - [quick_only] (default [false]). Don't run tests with the + {{!Core.speed_level} [`Slow] speed level}. + - [show_errors] (default [false]). Display the test errors. + - [json] (default [false]). Print test results in a JSON-compatible + format. + - [log_dir] (default ["$PWD/_build/_tests/"]). The directory in which to + log the output of the tests (if [verbose] is not set). *) + + val merge : t -> t -> t +end + +(** {1:define Defining tests} *) -include module type of Alcotest_engine.Test (** @inline *) +include + Alcotest_engine.Cli.S + with type 'a m := 'a + and type 'a test_args := 'a + and type tag := Tag.t + and type tag_set := Tag.Set.t + and type config := Config.t + +(** {1 Testable values} + + The following combinators represent types that can be used with the {!check} + functions below. *) + +include module type of Alcotest_engine.Test +(** @closed *) (** {1 Unix-specific engine constructors} @@ -50,3 +122,8 @@ end module Cli : sig module Make : module type of Alcotest_engine.Cli.Make (Unix) end + +module V1 : sig + include Alcotest_engine.Cli.V1 with type return = unit + include module type of Alcotest_engine.Test +end diff --git a/src/ppx_alcotest/.ocamlformat b/src/ppx_alcotest/.ocamlformat new file mode 100644 index 00000000..ad71063c --- /dev/null +++ b/src/ppx_alcotest/.ocamlformat @@ -0,0 +1,3 @@ +module-item-spacing = compact +# break-separators = before +# dock-collection-brackets = false diff --git a/src/ppx_alcotest/dune b/src/ppx_alcotest/dune new file mode 100644 index 00000000..007a54ff --- /dev/null +++ b/src/ppx_alcotest/dune @@ -0,0 +1,8 @@ +(library + (name ppx_alcotest) + (public_name ppx_alcotest) + (kind ppx_rewriter) + (libraries ppxlib fmt) + (ppx_runtime_libraries ppx_alcotest.runtime) + (preprocess + (pps ppxlib.metaquot))) diff --git a/src/ppx_alcotest/infer.ml b/src/ppx_alcotest/infer.ml new file mode 100644 index 00000000..0eed81f6 --- /dev/null +++ b/src/ppx_alcotest/infer.ml @@ -0,0 +1,184 @@ +open Ppxlib + +let return x = Some x +let ( >>= ) x f = match x with None -> None | Some x -> f x + +(** Representation of types with corresponding combinators in Alcotest. *) +type typ = + | Any + | Custom of string + | Unit + | Bool + | Int + | Int32 + | Int64 + | Float + | Char + | String + | Bytes + | List of typ + | Array of typ + | Option of typ + | Result of typ * typ + | Pair of typ * typ + | Triple of typ * typ * typ + +let combinator_name_of_type_name = function + | "t" -> "testable" + | s -> s ^ "_testable" + +let comb ~loc : typ -> expression = + let rec aux = function + | Custom n -> Ast_builder.Default.evar ~loc (combinator_name_of_type_name n) + | Any -> [%expr Alcotest.fail] + | Unit -> [%expr Alcotest.unit] + | Bool -> [%expr Alcotest.bool] + | Int -> [%expr Alcotest.int] + | Int32 -> [%expr Alcotest.int32] + | Int64 -> [%expr Alcotest.int64] + | Float -> [%expr Alcotest.float 1. (* TODO *)] + | Char -> [%expr Alcotest.char] + | String -> [%expr Alcotest.string] + | Bytes -> [%expr Alcotest.bytes] + | List a -> [%expr Alcotest.list [%e aux a]] + | Array a -> [%expr Alcotest.array [%e aux a]] + | Option a -> [%expr Alcotest.option [%e aux a]] + | Result (a, e) -> [%expr Alcotest.result [%e aux a] [%e aux e]] + | Pair (a, b) -> [%expr Alcotest.pair [%e aux a] [%e aux b]] + | Triple (a, b, c) -> + [%expr Alcotest.triple [%e aux a] [%e aux b] [%e aux c]] + in + aux + +let rec unify a b = + match (a, b) with + | Any, x | x, Any -> x + | (Custom a as t), Custom b -> if String.equal a b then t else assert false + | Unit, Unit -> Unit + | Bool, Bool -> Bool + | Int, Int -> Int + | Int32, Int32 -> Int32 + | Int64, Int64 -> Int64 + | Float, Float -> Float + | Char, Char -> Char + | String, String -> String + | Bytes, Bytes -> Bytes + | List a, List b -> List (unify a b) + | Array a, Array b -> Array (unify a b) + | Option a, Option b -> Option (unify a b) + | Result (a1, e1), Result (a2, e2) -> Result (unify a1 a2, unify e1 e2) + | Pair (a1, b1), Pair (a2, b2) -> Pair (unify a1 a2, unify b1 b2) + | Triple (a1, b1, c1), Triple (a2, b2, c2) -> + Triple (unify a1 a2, unify b1 b2, unify c1 c2) + | ( ( Custom _ | Unit | Bool | Int | Int32 | Int64 | Float | Char | String + | Bytes | List _ | Array _ | Option _ | Result _ | Pair _ | Triple _ ), + _ ) -> + failwith "Unable to unify mismatched types" + +(** This module provides a very basic inference of structural types of + expressions.*) + +let lift_constructor c ts = + match (c, ts) with + | "list", [ a ] -> List a + | "result", [ a; e ] -> Result (a, e) + | "option", [ a ] -> Option a + | s, _ -> Format.kasprintf failwith "unknown constructor: %s" s + +let rec core_type : core_type -> typ option = + fun t -> + let x = t.ptyp_desc in + match x with + | Ptyp_any | Ptyp_var _ -> return Any + | Ptyp_tuple [ t1; t2 ] -> + core_type t1 >>= fun t1 -> + core_type t2 >>= fun t2 -> return @@ Pair (t1, t2) + | Ptyp_tuple [ t1; t2; t3 ] -> + core_type t1 >>= fun t1 -> + core_type t2 >>= fun t2 -> + core_type t3 >>= fun t3 -> return @@ Triple (t1, t2, t3) + | Ptyp_tuple _ -> failwith "tuple" + | Ptyp_constr (c, []) -> ( + match c.txt with + | Lident "int" -> return Int + | Lident "" | _ -> failwith "todo") + | Ptyp_constr (c, ts) -> ( + let ts = + ListLabels.filter_map ts ~f:core_type + (* TODO: ensure no drop *) + in + match c.txt with + | Lident c -> return (lift_constructor c ts) + | _ -> failwith "lident todo") + | Ptyp_alias (_, _) + | Ptyp_variant (_, _, _) + | Ptyp_poly (_, _) + | Ptyp_arrow _ | Ptyp_object _ | Ptyp_class _ | Ptyp_package _ + | Ptyp_extension _ -> + None + +let rec expression : expression -> typ option = + fun e -> + match e with + | { + pexp_desc = + Pexp_ifthenelse (_, _, None) | Pexp_setfield _ | Pexp_while _ | Pexp_for _; + _; + } -> + return Unit + | { pexp_desc = Pexp_constant c; _ } -> ( + match c with + | Pconst_char _ -> return Char + | Pconst_integer (_, None) -> return Int + | Pconst_integer (_, Some 'l') -> return Int32 + | Pconst_integer (_, Some 'L') -> return Int64 + | Pconst_integer (_, Some _) -> None + | Pconst_string _ -> return String + | Pconst_float (_, _) -> return Float) + | { pexp_desc = Pexp_tuple t; _ } -> ( + match t with + | [ e1; e2 ] -> + expression e1 >>= fun t1 -> + expression e2 >>= fun t2 -> return (Pair (t1, t2)) + | [ e1; e2; e3 ] -> + expression e1 >>= fun t1 -> + expression e2 >>= fun t2 -> + expression e3 >>= fun t3 -> return (Triple (t1, t2, t3)) + | _ -> failwith "tuple") + | [%expr None] -> return (Option Any) + | [%expr Some [%e? x]] -> expression x >>= fun t -> return @@ Option t + | [%expr Ok [%e? x]] -> expression x >>= fun t -> return @@ Result (t, Any) + | [%expr Error [%e? x]] -> expression x >>= fun t -> return @@ Result (Any, t) + | { pexp_desc = Pexp_construct (_, _); _ } -> assert false + | { pexp_desc = Pexp_array es; _ } -> + ListLabels.fold_left es ~init:None ~f:(fun acc x -> + match acc with Some _ as t -> t | None -> expression x) + | { pexp_desc = Pexp_ifthenelse (_, e1, Some e2); _ } -> ( + match (expression e1, expression e2) with + | None, None -> None + | (Some _ as t), None | None, (Some _ as t) -> t + | Some x, Some y -> return (unify x y)) + | { pexp_desc = Pexp_constraint (_, t) | Pexp_coerce (_, _, t); _ } -> + core_type t + | { + pexp_desc = + ( Pexp_let (_, _, e) + | Pexp_letmodule (_, _, e) + | Pexp_letexception (_, e) + | Pexp_open (_, e) + | Pexp_sequence (_, e) ); + _; + } -> + expression e + (* Expressions for which we make no attempt at inference *) + | { + pexp_desc = + ( Pexp_apply _ | Pexp_assert _ | Pexp_extension _ + | Pexp_field (_, _) + | Pexp_fun _ | Pexp_function _ | Pexp_ident _ | Pexp_lazy _ | Pexp_letop _ + | Pexp_match _ | Pexp_new _ | Pexp_newtype _ | Pexp_object _ + | Pexp_override _ | Pexp_pack _ | Pexp_poly _ | Pexp_record _ | Pexp_send _ + | Pexp_setinstvar _ | Pexp_try _ | Pexp_unreachable | Pexp_variant _ ); + _; + } -> + None diff --git a/src/ppx_alcotest/ppx_alcotest.ml b/src/ppx_alcotest/ppx_alcotest.ml new file mode 100644 index 00000000..795c6940 --- /dev/null +++ b/src/ppx_alcotest/ppx_alcotest.ml @@ -0,0 +1,150 @@ +open Ppxlib + +module type S = sig + val check : core_type -> expression + val run_tests : structure_item + val here : expression + val collect_tests : structure -> structure +end + +module Located (A : Ast_builder.S) : S = struct + open A + + module Collection_site = struct + let p = [%pat? _ppx_alcotest_suite] + let e = [%expr _ppx_alcotest_suite] + let add to_add = [%stri let [%p p] = [%e to_add] :: [%e e]] + let from_module name = evar (name ^ "._ppx_alcotest_suite") + end + + let collector = + object (collector) + inherit [bool] Ast_traverse.fold_map as super + + method! structure t _ = + match super#structure t false with + | (_, false) as x -> x + | items, true -> ([%stri let [%p Collection_site.p] = []] :: items, true) + + method! structure_item t acc = + match t with + | { + pstr_desc = Pstr_extension (({ txt = "test"; _ }, payload), _attrs); + _; + } -> ( + match payload with + (* [ module%test = ] *) + | PStr + [ + { + pstr_desc = + Pstr_module + { + pmb_name = { txt = module_name; _ }; + pmb_expr = body; + _; + }; + _; + }; + ] -> + let module_name = Option.get module_name in + let item = + let name = Located.mk (Some module_name) in + let expr, _ = collector#module_expr body false in + [%stri + include struct + [%%i pstr_module (module_binding ~name ~expr)] + + [%%i + Collection_site.add + [%expr + Alcotest.group ~name:[%e estring module_name] + (Stdlib.List.rev + [%e Collection_site.from_module module_name])]] + end] + in + (item, true) + (* [ let%test = ] *) + | PStr [ [%stri let [%p? test_name] = [%e? body]] ] -> + let test_name = + match test_name.ppat_desc with + | Ppat_constant (Pconst_string (s, _, _)) -> s + | Ppat_constant (Pconst_integer (s, _)) -> s + | _ -> Raise.invalid_test_name test_name + in + let test = + [%stri + include struct + let [%p pvar ("_ppx_test__" ^ test_name)] = + fun () -> [%e body] + + [%%i + Collection_site.add + [%expr + Alcotest.test ~name:[%e estring test_name] + [%e evar ("_ppx_test__" ^ test_name)]]] + end] + in + (test, true) + | _ -> assert false) + | { pstr_desc = Pstr_module _; _ } -> + let x, _ = super#structure_item t false in + (x, false) + | _ -> super#structure_item t acc + end + + let collect_tests s = fst (collector#structure s false) + + let run_tests = + [%stri + let () = + Ppx_alcotest_runtime.run ~name:__FILE__ + (Stdlib.List.rev [%e Collection_site.e])] + + let here = + let pos = loc.Location.loc_start in + let id = Located.lident in + pexp_record + [ + (id "Lexing.pos_fname", estring pos.Lexing.pos_fname); + (id "pos_lnum", eint pos.Lexing.pos_lnum); + (id "pos_cnum", eint pos.Lexing.pos_cnum); + (id "pos_bol", eint pos.Lexing.pos_bol); + ] + None + + let check typ = + let testable = + match Infer.core_type typ with + | None -> failwith "bad" + | Some x -> Infer.comb ~loc x + in + [%expr + fun ?(here = [%e here]) ?msg ~expected actual -> + Ppx_alcotest_runtime.check ~here ~testable:[%e testable] ?msg ~expected + actual] +end + +let test_collection = + let (module A) = Ast_builder.make Location.none in + let (module X) = (module Located (A) : S) in + X.collect_tests + +let extensions = + let declare name ctx pat f = + Extension.declare ("Alcotest." ^ name) ctx pat (fun ~loc ~path:_ -> + let (module A) = Ast_builder.make loc in + f (module Located (A) : S)) + in + let module E = Extension.Context in + let module A = Ast_pattern in + [ + declare "check" E.expression A.(ptyp __) (fun (module X) -> X.check); + declare "here" E.expression A.(pstr nil) (fun (module X) -> X.here); + declare "run_tests" E.structure_item + A.(pstr nil) + (fun (module X) -> X.run_tests); + ] + +let () = + Driver.register_transformation ~extensions ~impl:test_collection "alcotest" diff --git a/src/ppx_alcotest/ppx_alcotest.mli b/src/ppx_alcotest/ppx_alcotest.mli new file mode 100644 index 00000000..e264e69e --- /dev/null +++ b/src/ppx_alcotest/ppx_alcotest.mli @@ -0,0 +1 @@ +(* intentionally empty *) diff --git a/src/ppx_alcotest/raise.ml b/src/ppx_alcotest/raise.ml new file mode 100644 index 00000000..234368f4 --- /dev/null +++ b/src/ppx_alcotest/raise.ml @@ -0,0 +1,5 @@ +open Ppxlib + +let invalid_test_name pattern = + Location.raise_errorf ~loc:pattern.ppat_loc + "Unsupported test name type. Use a literal string or an integer." diff --git a/src/ppx_alcotest/raise.mli b/src/ppx_alcotest/raise.mli new file mode 100644 index 00000000..83e99b14 --- /dev/null +++ b/src/ppx_alcotest/raise.mli @@ -0,0 +1,3 @@ +open Ppxlib + +val invalid_test_name : pattern -> _ diff --git a/src/ppx_alcotest/runtime/dune b/src/ppx_alcotest/runtime/dune new file mode 100644 index 00000000..fab0543b --- /dev/null +++ b/src/ppx_alcotest/runtime/dune @@ -0,0 +1,4 @@ +(library + (name ppx_alcotest_runtime) + (public_name ppx_alcotest.runtime) + (libraries alcotest alcotest.engine)) diff --git a/src/ppx_alcotest/runtime/ppx_alcotest_runtime.ml b/src/ppx_alcotest/runtime/ppx_alcotest_runtime.ml new file mode 100644 index 00000000..bd690d85 --- /dev/null +++ b/src/ppx_alcotest/runtime/ppx_alcotest_runtime.ml @@ -0,0 +1,12 @@ +let check : + 'a. + here:Lexing.position -> + ?msg:string -> + testable:'a Alcotest.testable -> + expected:'a -> + 'a -> + unit = + fun ~here ?(msg = "") ~testable ~expected actual -> + Alcotest.check ~here testable msg expected actual + +let run ~name tests = Alcotest.run ~name tests diff --git a/test/e2e/alcotest-lwt/dune b/test/e2e/alcotest-lwt/dune index 7e853d4f..db42377c 100644 --- a/test/e2e/alcotest-lwt/dune +++ b/test/e2e/alcotest-lwt/dune @@ -1,4 +1,4 @@ (env (_ (env-vars - (ALCOTEST_COLOR auto)))) + (ALCOTEST_COLOR never)))) diff --git a/test/e2e/alcotest-lwt/failing/async_failure.expected b/test/e2e/alcotest-lwt/failing/async_failure.expected index bfb5af40..f32cb08a 100644 --- a/test/e2e/alcotest-lwt/failing/async_failure.expected +++ b/test/e2e/alcotest-lwt/failing/async_failure.expected @@ -1,17 +1,15 @@ Testing `test/e2e/alcotest-lwt/failing/async_failure.ml'. This run has ID `'. -> [FAIL] all 0 one. - [OK] all 1 two. +> [FAIL] all β€Ί one + [PASS] all β€Ί two β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] all 0 one. β”‚ +β”‚ [FAIL] all β€Ί one β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -freeing all resources -[failure] All is broken - -Logs saved to `/_build/_tests//all.000.output'. +All is broken ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 2 tests run. + diff --git a/test/e2e/alcotest-lwt/failing/async_failure.ml b/test/e2e/alcotest-lwt/failing/async_failure.ml index c09391ae..be9d6b0d 100644 --- a/test/e2e/alcotest-lwt/failing/async_failure.ml +++ b/test/e2e/alcotest-lwt/failing/async_failure.ml @@ -8,7 +8,7 @@ let test_lwt switch () = Lwt_unix.sleep 10. let () = - let open Alcotest_lwt in + let open Alcotest_lwt.V1 in Lwt_main.run @@ run __FILE__ [ diff --git a/test/e2e/alcotest-lwt/failing/dune.inc b/test/e2e/alcotest-lwt/failing/dune.inc index 07442a44..a0fc47e5 100644 --- a/test/e2e/alcotest-lwt/failing/dune.inc +++ b/test/e2e/alcotest-lwt/failing/dune.inc @@ -4,6 +4,7 @@ fail_with ) (libraries alcotest alcotest-lwt lwt lwt.unix) + (preprocess (pps ppx_alcotest)) (modules async_failure fail_with diff --git a/test/e2e/alcotest-lwt/failing/fail_with.expected b/test/e2e/alcotest-lwt/failing/fail_with.expected index ab5369c3..1d48d91a 100644 --- a/test/e2e/alcotest-lwt/failing/fail_with.expected +++ b/test/e2e/alcotest-lwt/failing/fail_with.expected @@ -1,16 +1,15 @@ Testing `test/e2e/alcotest-lwt/failing/fail_with.ml'. This run has ID `'. -> [FAIL] all 0 one. - [OK] all 1 two. +> [FAIL] all β€Ί one + [PASS] all β€Ί two β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] all 0 one. β”‚ +β”‚ [FAIL] all β€Ί one β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -[failure] should fail - -Logs saved to `/_build/_tests//all.000.output'. +should fail ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 2 tests run. + diff --git a/test/e2e/alcotest-lwt/failing/fail_with.ml b/test/e2e/alcotest-lwt/failing/fail_with.ml index 4f051e17..2855f9fd 100644 --- a/test/e2e/alcotest-lwt/failing/fail_with.ml +++ b/test/e2e/alcotest-lwt/failing/fail_with.ml @@ -1,7 +1,7 @@ let test_lwt _switch () = Lwt.fail_with "should fail" let () = - let open Alcotest_lwt in + let open Alcotest_lwt.V1 in Lwt_main.run @@ run __FILE__ [ diff --git a/test/e2e/alcotest-lwt/passing/cli_options.ml b/test/e2e/alcotest-lwt/passing/cli_options.ml index 19d8a24e..7118df08 100644 --- a/test/e2e/alcotest-lwt/passing/cli_options.ml +++ b/test/e2e/alcotest-lwt/passing/cli_options.ml @@ -1,3 +1,5 @@ +module Alcotest_lwt = Alcotest_lwt.V1 + let () = let open Alcotest_lwt in Lwt_main.run diff --git a/test/e2e/alcotest-lwt/passing/dune.inc b/test/e2e/alcotest-lwt/passing/dune.inc index 75aa7456..90a9920e 100644 --- a/test/e2e/alcotest-lwt/passing/dune.inc +++ b/test/e2e/alcotest-lwt/passing/dune.inc @@ -3,6 +3,7 @@ cli_options ) (libraries alcotest alcotest-lwt lwt lwt.unix) + (preprocess (pps ppx_alcotest)) (modules cli_options ) diff --git a/test/e2e/alcotest/failing/bail.expected b/test/e2e/alcotest/failing/bail.expected index e76d3d9d..bb19b700 100644 --- a/test/e2e/alcotest/failing/bail.expected +++ b/test/e2e/alcotest/failing/bail.expected @@ -1,18 +1,15 @@ Testing `test/e2e/alcotest/failing/bail.ml'. This run has ID `'. - [OK] passing 0 a. -> [FAIL] failing 0 b. - - ... with 1 subsequent test skipped. + [PASS] passing β€Ί a +> [FAIL] failing β€Ί b β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] failing 0 b. β”‚ +β”‚ [FAIL] failing β€Ί b β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -[failure] Expected failure - -Logs saved to `/_build/_tests//failing.000.output'. +Expected failure ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 2 tests run. + diff --git a/test/e2e/alcotest/failing/bail.ml b/test/e2e/alcotest/failing/bail.ml index 527f5961..3e200438 100644 --- a/test/e2e/alcotest/failing/bail.ml +++ b/test/e2e/alcotest/failing/bail.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let tc name f = Alcotest.test_case name `Quick f in Alcotest.run ~bail:true __FILE__ diff --git a/test/e2e/alcotest/failing/check_basic.expected b/test/e2e/alcotest/failing/check_basic.expected index 596df52b..163c6756 100644 --- a/test/e2e/alcotest/failing/check_basic.expected +++ b/test/e2e/alcotest/failing/check_basic.expected @@ -2,36 +2,36 @@ Testing `test/e2e/alcotest/failing/check_basic.ml'. This run has ID `'. ASSERT bool - [FAIL] different basic 0 bool. + [FAIL] different basic β€Ί bool ASSERT int - [FAIL] different basic 1 int. + [FAIL] different basic β€Ί int ASSERT int32 - [FAIL] different basic 2 int32. + [FAIL] different basic β€Ί int32 ASSERT int64 - [FAIL] different basic 3 int64. + [FAIL] different basic β€Ί int64 ASSERT float - [FAIL] different basic 4 float. + [FAIL] different basic β€Ί float ASSERT char - [FAIL] different basic 5 char. + [FAIL] different basic β€Ί char ASSERT string - [FAIL] different basic 6 string. + [FAIL] different basic β€Ί string ASSERT bytes - [FAIL] different basic 7 bytes. + [FAIL] different basic β€Ί bytes ASSERT list - [FAIL] different composite 0 list. + [FAIL] different composite β€Ί list ASSERT array - [FAIL] different composite 1 array. + [FAIL] different composite β€Ί array ASSERT option some - [FAIL] different composite 2 option some. + [FAIL] different composite β€Ί option some ASSERT result - [FAIL] different composite 3 result. + [FAIL] different composite β€Ί result ASSERT pair - [FAIL] different composite 4 pair. + [FAIL] different composite β€Ί pair ASSERT triple - [FAIL] different composite 5 triple. + [FAIL] different composite β€Ί triple β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 0 bool. β”‚ +β”‚ [FAIL] different basic β€Ί bool β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL bool @@ -41,7 +41,7 @@ FAIL bool β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 1 int. β”‚ +β”‚ [FAIL] different basic β€Ί int β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL int @@ -51,7 +51,7 @@ FAIL int β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 2 int32. β”‚ +β”‚ [FAIL] different basic β€Ί int32 β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL int32 @@ -61,7 +61,7 @@ FAIL int32 β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 3 int64. β”‚ +β”‚ [FAIL] different basic β€Ί int64 β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL int64 @@ -71,7 +71,7 @@ FAIL int64 β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 4 float. β”‚ +β”‚ [FAIL] different basic β€Ί float β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL float @@ -81,7 +81,7 @@ FAIL float β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 5 char. β”‚ +β”‚ [FAIL] different basic β€Ί char β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL char @@ -91,7 +91,7 @@ FAIL char β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 6 string. β”‚ +β”‚ [FAIL] different basic β€Ί string β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL string @@ -101,7 +101,7 @@ FAIL string β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different basic 7 bytes. β”‚ +β”‚ [FAIL] different basic β€Ί bytes β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL bytes @@ -111,7 +111,7 @@ FAIL bytes β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 0 list. β”‚ +β”‚ [FAIL] different composite β€Ί list β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL list @@ -121,7 +121,7 @@ FAIL list β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 1 array. β”‚ +β”‚ [FAIL] different composite β€Ί array β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL array @@ -131,7 +131,7 @@ FAIL array β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 2 option some. β”‚ +β”‚ [FAIL] different composite β€Ί option some β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL option some @@ -141,7 +141,7 @@ FAIL option some β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 3 result. β”‚ +β”‚ [FAIL] different composite β€Ί result β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL result @@ -151,7 +151,7 @@ FAIL result β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 4 pair. β”‚ +β”‚ [FAIL] different composite β€Ί pair β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL pair @@ -161,7 +161,7 @@ FAIL pair β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] different composite 5 triple. β”‚ +β”‚ [FAIL] different composite β€Ί triple β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL triple @@ -170,3 +170,4 @@ FAIL triple ────────────────────────────────────────────────────────────────────────────── 14 failures! in s. 14 tests run. + diff --git a/test/e2e/alcotest/failing/check_basic.ml b/test/e2e/alcotest/failing/check_basic.ml index c4bf0645..e13a8058 100644 --- a/test/e2e/alcotest/failing/check_basic.ml +++ b/test/e2e/alcotest/failing/check_basic.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + (* Check that v of type [typ] matches with itself *) let id_case typ typ_str v1 v2 = Alcotest.test_case typ_str `Quick (fun () -> Alcotest.check typ typ_str v1 v2) diff --git a/test/e2e/alcotest/failing/check_located.expected b/test/e2e/alcotest/failing/check_located.expected index 3f870160..cb92ea13 100644 --- a/test/e2e/alcotest/failing/check_located.expected +++ b/test/e2e/alcotest/failing/check_located.expected @@ -2,20 +2,20 @@ Testing `test/e2e/alcotest/failing/check_located.ml'. This run has ID `'. ASSERT Expected failure - [FAIL] check 0 here. + [FAIL] check β€Ί here ASSERT Expected failure - [FAIL] check 1 pos. + [FAIL] check β€Ί pos ASSERT Expected failure - [FAIL] check_raises 0 here. + [FAIL] check_raises β€Ί here ASSERT Expected failure - [FAIL] check_raises 1 pos. + [FAIL] check_raises β€Ί pos ASSERT Expected failure - [FAIL] fail 0 here. + [FAIL] fail β€Ί here ASSERT Expected failure - [FAIL] fail 1 pos. + [FAIL] fail β€Ί pos β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] check 0 here. β”‚ +β”‚ [FAIL] check β€Ί here β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30: FAIL Expected failure @@ -26,7 +26,7 @@ FAIL Expected failure β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] check 1 pos. β”‚ +β”‚ [FAIL] check β€Ί pos β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10: FAIL Expected failure @@ -37,7 +37,7 @@ FAIL Expected failure β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] check_raises 0 here. β”‚ +β”‚ [FAIL] check_raises β€Ί here β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30: FAIL Expected failure: expecting Failure(""), got nothing. @@ -45,7 +45,7 @@ FAIL Expected failure: expecting Failure(""), got nothing. β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] check_raises 1 pos. β”‚ +β”‚ [FAIL] check_raises β€Ί pos β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10: FAIL Expected failure: expecting Failure(""), got nothing. @@ -53,7 +53,7 @@ FAIL Expected failure: expecting Failure(""), got nothing. β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] fail 0 here. β”‚ +β”‚ [FAIL] fail β€Ί here β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 2, character 30: FAIL Expected failure @@ -61,10 +61,11 @@ FAIL Expected failure β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] fail 1 pos. β”‚ +β”‚ [FAIL] fail β€Ί pos β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ File "test/e2e/alcotest/failing/check_located.ml", line 4, character 10: FAIL Expected failure ────────────────────────────────────────────────────────────────────────────── 6 failures! in s. 6 tests run. + diff --git a/test/e2e/alcotest/failing/check_located.ml b/test/e2e/alcotest/failing/check_located.ml index 6d67683a..fec9c36d 100644 --- a/test/e2e/alcotest/failing/check_located.ml +++ b/test/e2e/alcotest/failing/check_located.ml @@ -3,6 +3,8 @@ let here : Lexing.position = let pos = __POS__ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let msg = "Expected failure" in diff --git a/test/e2e/alcotest/failing/check_long.expected b/test/e2e/alcotest/failing/check_long.expected index 1a730633..f67b50b2 100644 --- a/test/e2e/alcotest/failing/check_long.expected +++ b/test/e2e/alcotest/failing/check_long.expected @@ -2,14 +2,14 @@ Testing `test/e2e/alcotest/failing/check_long.ml'. This run has ID `'. ASSERT list - [FAIL] wrapping 0 list. + [FAIL] wrapping β€Ί list ASSERT array - [FAIL] wrapping 1 array. + [FAIL] wrapping β€Ί array ASSERT nested options - [FAIL] wrapping 2 nested options. + [FAIL] wrapping β€Ί nested options β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] wrapping 0 list. β”‚ +β”‚ [FAIL] wrapping β€Ί list β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL list @@ -22,7 +22,7 @@ FAIL list β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] wrapping 1 array. β”‚ +β”‚ [FAIL] wrapping β€Ί array β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL array @@ -47,7 +47,7 @@ FAIL array β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] wrapping 2 nested options. β”‚ +β”‚ [FAIL] wrapping β€Ί nested options β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL nested options @@ -125,3 +125,4 @@ FAIL nested options ────────────────────────────────────────────────────────────────────────────── 3 failures! in s. 3 tests run. + diff --git a/test/e2e/alcotest/failing/check_long.ml b/test/e2e/alcotest/failing/check_long.ml index cca87f67..1da4ce54 100644 --- a/test/e2e/alcotest/failing/check_long.ml +++ b/test/e2e/alcotest/failing/check_long.ml @@ -1,6 +1,7 @@ (** These tests check the wrapping behaviour of [Alcotest.check]'s emitted diff. *) -open Alcotest_engine.Private.Utils +module Alcotest = Alcotest.V1 +open Alcotest_engine.Stdlib_ext let id_case typ typ_str v1 v2 = Alcotest.test_case typ_str `Quick (fun () -> Alcotest.check typ typ_str v1 v2) diff --git a/test/e2e/alcotest/failing/compact.expected b/test/e2e/alcotest/failing/compact.expected index 2421da78..25748363 100644 --- a/test/e2e/alcotest/failing/compact.expected +++ b/test/e2e/alcotest/failing/compact.expected @@ -4,12 +4,11 @@ This run has ID `'. ..F... β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] alpha 2 3. β”‚ +β”‚ [FAIL] alpha β€Ί 3 β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -[failure] Error - -Logs saved to `/_build/_tests//alpha.002.output'. +Error ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 6 tests run. + diff --git a/test/e2e/alcotest/failing/compact.ml b/test/e2e/alcotest/failing/compact.ml index 2dbb386b..4f077c72 100644 --- a/test/e2e/alcotest/failing/compact.ml +++ b/test/e2e/alcotest/failing/compact.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let passing s = test_case s `Quick (fun () -> ()) in diff --git a/test/e2e/alcotest/failing/dune.inc b/test/e2e/alcotest/failing/dune.inc index 8d5a8238..1d300b16 100644 --- a/test/e2e/alcotest/failing/dune.inc +++ b/test/e2e/alcotest/failing/dune.inc @@ -17,6 +17,7 @@ unknown_option ) (libraries alcotest alcotest.engine) + (preprocess (pps ppx_alcotest)) (modules bail check_basic diff --git a/test/e2e/alcotest/failing/duplicate_test_names.expected b/test/e2e/alcotest/failing/duplicate_test_names.expected index fa1fdd79..1459f2f2 100644 --- a/test/e2e/alcotest/failing/duplicate_test_names.expected +++ b/test/e2e/alcotest/failing/duplicate_test_names.expected @@ -1 +1,15 @@ -ERROR: Duplicate test path: `duped' +Testing `test/e2e/alcotest/failing/duplicate_test_names.ml'. +This run has ID `'. + +> [FAIL] duped β€Ί 1 + [FAIL] duped β€Ί 2 + +β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” +β”‚ [FAIL] duped β€Ί 1 β”‚ +β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ +File "test/e2e/alcotest/failing/duplicate_test_names.ml", line 8, characters 59-65: Assertion failed + ────────────────────────────────────────────────────────────────────────────── + +Full test results in `/_build/_tests/'. +2 failures! in s. 2 tests run. + diff --git a/test/e2e/alcotest/failing/duplicate_test_names.ml b/test/e2e/alcotest/failing/duplicate_test_names.ml index d1ae64c4..790ec990 100644 --- a/test/e2e/alcotest/failing/duplicate_test_names.ml +++ b/test/e2e/alcotest/failing/duplicate_test_names.ml @@ -1,5 +1,7 @@ (** Ensure that suites with duplicate test names are rejected. *) +module Alcotest = Alcotest.V1 + let () = Alcotest.run __FILE__ [ diff --git a/test/e2e/alcotest/failing/empty_suite_name.expected b/test/e2e/alcotest/failing/empty_suite_name.expected index 99d335bf..b39f4014 100644 --- a/test/e2e/alcotest/failing/empty_suite_name.expected +++ b/test/e2e/alcotest/failing/empty_suite_name.expected @@ -1 +1,2 @@ ERROR: Suite name cannot cannot be empty. Please pass a non-empty string to `run`. + diff --git a/test/e2e/alcotest/failing/empty_suite_name.ml b/test/e2e/alcotest/failing/empty_suite_name.ml index 1b98b13e..2f6c9501 100644 --- a/test/e2e/alcotest/failing/empty_suite_name.ml +++ b/test/e2e/alcotest/failing/empty_suite_name.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = Alcotest.run "" [ ("alpha", [ Alcotest.test_case "1" `Quick (fun () -> assert false) ]) ] diff --git a/test/e2e/alcotest/failing/exception_in_test.expected b/test/e2e/alcotest/failing/exception_in_test.expected index be57eb2d..be97e2b1 100644 --- a/test/e2e/alcotest/failing/exception_in_test.expected +++ b/test/e2e/alcotest/failing/exception_in_test.expected @@ -1,17 +1,16 @@ Testing `test/e2e/alcotest/failing/exception_in_test.ml'. This run has ID `'. - [OK] test-a 0 Passing. -> [FAIL] test-a 1 Failing. - [OK] test-b 0 Another pass. + [PASS] test-a β€Ί Passing +> [FAIL] test-a β€Ί Failing + [PASS] test-b β€Ί Another pass β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] test-a 1 Failing. β”‚ +β”‚ [FAIL] test-a β€Ί Failing β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -[exception] Dune__exe__Exception_in_test.Foo("message") - -Logs saved to `/_build/_tests//test-a.001.output'. +Dune__exe__Exception_in_test.Foo("message") ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 3 tests run. + diff --git a/test/e2e/alcotest/failing/exception_in_test.ml b/test/e2e/alcotest/failing/exception_in_test.ml index 49e0d013..fc2269d5 100644 --- a/test/e2e/alcotest/failing/exception_in_test.ml +++ b/test/e2e/alcotest/failing/exception_in_test.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + exception Foo of string let () = diff --git a/test/e2e/alcotest/failing/filter_all_tests.expected b/test/e2e/alcotest/failing/filter_all_tests.expected index 5812154b..5702a071 100644 --- a/test/e2e/alcotest/failing/filter_all_tests.expected +++ b/test/e2e/alcotest/failing/filter_all_tests.expected @@ -1,4 +1,3 @@ -Invalid request (no tests to run, filter skipped everything)! -Testing `test/e2e/alcotest/failing/filter_all_tests.ml'. -This run has ID `'. - +filter_all_tests.exe: too many arguments, don't know what to do with `bar', `1' +Usage: filter_all_tests.exe test [OPTION]... +Try `filter_all_tests.exe test --help' or `filter_all_tests.exe --help' for more information. diff --git a/test/e2e/alcotest/failing/filter_all_tests.ml b/test/e2e/alcotest/failing/filter_all_tests.ml index 481bf0e6..487edfed 100644 --- a/test/e2e/alcotest/failing/filter_all_tests.ml +++ b/test/e2e/alcotest/failing/filter_all_tests.ml @@ -1,5 +1,7 @@ (** Ensure that filters which eliminate all tests are rejected. *) +module Alcotest = Alcotest.V1 + let () = Alcotest.run __FILE__ [ diff --git a/test/e2e/alcotest/failing/invalid_arg_in_test.expected b/test/e2e/alcotest/failing/invalid_arg_in_test.expected index 6301cafc..8fa184a1 100644 --- a/test/e2e/alcotest/failing/invalid_arg_in_test.expected +++ b/test/e2e/alcotest/failing/invalid_arg_in_test.expected @@ -1,17 +1,16 @@ Testing `test/e2e/alcotest/failing/invalid_arg_in_test.ml'. This run has ID `'. - [OK] test-a 0 Passing. -> [FAIL] test-a 1 Failing. - [OK] test-b 0 Another pass. + [PASS] test-a β€Ί Passing +> [FAIL] test-a β€Ί Failing + [PASS] test-b β€Ί Another pass β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] test-a 1 Failing. β”‚ +β”‚ [FAIL] test-a β€Ί Failing β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -[invalid] Failing test - -Logs saved to `/_build/_tests//test-a.001.output'. +Failing test ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 3 tests run. + diff --git a/test/e2e/alcotest/failing/invalid_arg_in_test.ml b/test/e2e/alcotest/failing/invalid_arg_in_test.ml index d8cfc67f..9b401c51 100644 --- a/test/e2e/alcotest/failing/invalid_arg_in_test.ml +++ b/test/e2e/alcotest/failing/invalid_arg_in_test.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in run __FILE__ diff --git a/test/e2e/alcotest/failing/long_test_case_name.expected b/test/e2e/alcotest/failing/long_test_case_name.expected index 0554aa9b..535b593f 100644 --- a/test/e2e/alcotest/failing/long_test_case_name.expected +++ b/test/e2e/alcotest/failing/long_test_case_name.expected @@ -1,17 +1,15 @@ Testing `test/e2e/alcotest/failing/long_test_case_name.ml'. This run has ID `'. - [OK] test-a 0 Passing. -> [FAIL] test-a 1 Lorem ipsum dolor sit amet, consectetur a... + [PASS] test-a β€Ί Passing +> [FAIL] test-a β€Ί Lorem ipsum dolor sit amet, consectetur adipiscing elit.... -β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] test-a 1 Lorem ipsum dolor sit amet, consectetu... β”‚ -β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -ASSERT Failed +β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” +β”‚ [FAIL] test-a β€Ί Lorem ipsum dolor sit amet, consectetur adipiscing elit. Suspendisse... β”‚ +β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ FAIL Failed - -Logs saved to `/_build/_tests//test-a.001.output'. ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 2 tests run. + diff --git a/test/e2e/alcotest/failing/long_test_case_name.ml b/test/e2e/alcotest/failing/long_test_case_name.ml index bf435c11..fb2017d5 100644 --- a/test/e2e/alcotest/failing/long_test_case_name.ml +++ b/test/e2e/alcotest/failing/long_test_case_name.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in run __FILE__ diff --git a/test/e2e/alcotest/failing/tail_errors_limit.expected b/test/e2e/alcotest/failing/tail_errors_limit.expected index 89d2564b..52793765 100644 --- a/test/e2e/alcotest/failing/tail_errors_limit.expected +++ b/test/e2e/alcotest/failing/tail_errors_limit.expected @@ -1,25 +1,14 @@ Testing `test/e2e/alcotest/failing/tail_errors_limit.ml'. This run has ID `'. -> [FAIL] failing 0 test. +> [FAIL] failing β€Ί test β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] failing 0 test. β”‚ +β”‚ [FAIL] failing β€Ί test β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -... (omitting 92 lines) -output line 93 -output line 94 -output line 95 -output line 96 -output line 97 -output line 98 -output line 99 -output line 100 -ASSERT Logs should be 10 lines long, including this line (omitting 92). FAIL Logs should be 10 lines long, including this line (omitting 92). - -Logs saved to `/_build/_tests//failing.000.output'. ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 1 test run. + diff --git a/test/e2e/alcotest/failing/tail_errors_limit.ml b/test/e2e/alcotest/failing/tail_errors_limit.ml index 13e0a9c8..2061a451 100644 --- a/test/e2e/alcotest/failing/tail_errors_limit.ml +++ b/test/e2e/alcotest/failing/tail_errors_limit.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let test_error_output () = for i = 1 to 100 do Printf.printf "output line %i\n" i diff --git a/test/e2e/alcotest/failing/tail_errors_unlimited.expected b/test/e2e/alcotest/failing/tail_errors_unlimited.expected index 9a5eadc8..c6af2030 100644 --- a/test/e2e/alcotest/failing/tail_errors_unlimited.expected +++ b/test/e2e/alcotest/failing/tail_errors_unlimited.expected @@ -1,116 +1,14 @@ Testing `test/e2e/alcotest/failing/tail_errors_unlimited.ml'. This run has ID `'. -> [FAIL] failing 0 test. +> [FAIL] failing β€Ί test β”Œβ”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β” -β”‚ [FAIL] failing 0 test. β”‚ +β”‚ [FAIL] failing β€Ί test β”‚ β””β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”€β”˜ -output line 1 -output line 2 -output line 3 -output line 4 -output line 5 -output line 6 -output line 7 -output line 8 -output line 9 -output line 10 -output line 11 -output line 12 -output line 13 -output line 14 -output line 15 -output line 16 -output line 17 -output line 18 -output line 19 -output line 20 -output line 21 -output line 22 -output line 23 -output line 24 -output line 25 -output line 26 -output line 27 -output line 28 -output line 29 -output line 30 -output line 31 -output line 32 -output line 33 -output line 34 -output line 35 -output line 36 -output line 37 -output line 38 -output line 39 -output line 40 -output line 41 -output line 42 -output line 43 -output line 44 -output line 45 -output line 46 -output line 47 -output line 48 -output line 49 -output line 50 -output line 51 -output line 52 -output line 53 -output line 54 -output line 55 -output line 56 -output line 57 -output line 58 -output line 59 -output line 60 -output line 61 -output line 62 -output line 63 -output line 64 -output line 65 -output line 66 -output line 67 -output line 68 -output line 69 -output line 70 -output line 71 -output line 72 -output line 73 -output line 74 -output line 75 -output line 76 -output line 77 -output line 78 -output line 79 -output line 80 -output line 81 -output line 82 -output line 83 -output line 84 -output line 85 -output line 86 -output line 87 -output line 88 -output line 89 -output line 90 -output line 91 -output line 92 -output line 93 -output line 94 -output line 95 -output line 96 -output line 97 -output line 98 -output line 99 -output line 100 -ASSERT Logs above should be 101 lines long. FAIL Logs above should be 101 lines long. - -Logs saved to `/_build/_tests//failing.000.output'. ────────────────────────────────────────────────────────────────────────────── -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. 1 failure! in s. 1 test run. + diff --git a/test/e2e/alcotest/failing/tail_errors_unlimited.ml b/test/e2e/alcotest/failing/tail_errors_unlimited.ml index 028faa53..016df9aa 100644 --- a/test/e2e/alcotest/failing/tail_errors_unlimited.ml +++ b/test/e2e/alcotest/failing/tail_errors_unlimited.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let test_error_output () = for i = 1 to 100 do Printf.printf "output line %i\n" i diff --git a/test/e2e/alcotest/failing/unknown_option.ml b/test/e2e/alcotest/failing/unknown_option.ml index d515a14b..d11aeced 100644 --- a/test/e2e/alcotest/failing/unknown_option.ml +++ b/test/e2e/alcotest/failing/unknown_option.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = Alcotest.run __FILE__ [ ("alpha", [ Alcotest.test_case "1" `Quick (fun () -> ()) ]) ] diff --git a/test/e2e/alcotest/inside-dune/color-overridden.expected b/test/e2e/alcotest/inside-dune/color-overridden.expected index 5ef96460..b517ce02 100644 --- a/test/e2e/alcotest/inside-dune/color-overridden.expected +++ b/test/e2e/alcotest/inside-dune/color-overridden.expected @@ -1,9 +1,10 @@ Testing `test/e2e/alcotest/inside-dune/test_color.ml'. This run has ID `'. - [OK] alpha 0 Output may or may not contain ANSII escape... - [OK] alpha 1 according to whether or not [--color] is set. - [OK] alpha 2 (See the corresponding [dune] file.). + [PASS] alpha β€Ί Output may or may not contain ANSII escape codes + [PASS] alpha β€Ί according to whether or not [--color] is set. + [PASS] alpha β€Ί (See the corresponding [dune] file.) -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 3 tests run. + diff --git a/test/e2e/alcotest/inside-dune/test_color.ml b/test/e2e/alcotest/inside-dune/test_color.ml index 00377938..fddecfcd 100644 --- a/test/e2e/alcotest/inside-dune/test_color.ml +++ b/test/e2e/alcotest/inside-dune/test_color.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/and_exit_false.expected b/test/e2e/alcotest/passing/and_exit_false.expected index dbaba105..8b6848a3 100644 --- a/test/e2e/alcotest/passing/and_exit_false.expected +++ b/test/e2e/alcotest/passing/and_exit_false.expected @@ -1,8 +1,8 @@ Testing `test/e2e/alcotest/passing/and_exit_false.ml'. This run has ID `'. - [OK] test-a 0 Test case. + [PASS] test-a β€Ί Test case -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 1 test run. - Program execution continued! + diff --git a/test/e2e/alcotest/passing/and_exit_false.ml b/test/e2e/alcotest/passing/and_exit_false.ml index cf6bf21e..c7ed7983 100644 --- a/test/e2e/alcotest/passing/and_exit_false.ml +++ b/test/e2e/alcotest/passing/and_exit_false.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/and_exit_true.expected b/test/e2e/alcotest/passing/and_exit_true.expected index b5c5d7ed..3823f387 100644 --- a/test/e2e/alcotest/passing/and_exit_true.expected +++ b/test/e2e/alcotest/passing/and_exit_true.expected @@ -1,7 +1,8 @@ Testing `test/e2e/alcotest/passing/and_exit_true.ml'. This run has ID `'. - [OK] test-a 0 Test case. + [PASS] test-a β€Ί Test case -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 1 test run. + diff --git a/test/e2e/alcotest/passing/and_exit_true.ml b/test/e2e/alcotest/passing/and_exit_true.ml index 0e99c1ec..d5ab79e5 100644 --- a/test/e2e/alcotest/passing/and_exit_true.ml +++ b/test/e2e/alcotest/passing/and_exit_true.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/assert_and_verbose.expected b/test/e2e/alcotest/passing/assert_and_verbose.expected index a1890d58..88d6c4e0 100644 --- a/test/e2e/alcotest/passing/assert_and_verbose.expected +++ b/test/e2e/alcotest/passing/assert_and_verbose.expected @@ -3,18 +3,19 @@ This run has ID `'. ASSERT alpha-0 check alpha-0 standard out - [OK] alpha 0 check β†’ stdout. + [PASS] alpha β€Ί check β†’ stdout alpha-1 standard out ASSERT alpha-1 check - [OK] alpha 1 stdout β†’ check. + [PASS] alpha β€Ί stdout β†’ check ASSERT alpha-2 check alpha-2 standard error - [OK] alpha 2 check β†’ stderr. + [PASS] alpha β€Ί check β†’ stderr beta-0 standard out ASSERT beta-0 check beta-0 standard error - [OK] beta 0 stdout β†’ check β†’ stderr. + [PASS] beta β€Ί stdout β†’ check β†’ stderr Test Successful in s. 4 tests run. + diff --git a/test/e2e/alcotest/passing/assert_and_verbose.ml b/test/e2e/alcotest/passing/assert_and_verbose.ml index 989df47b..bcd56361 100644 --- a/test/e2e/alcotest/passing/assert_and_verbose.ml +++ b/test/e2e/alcotest/passing/assert_and_verbose.ml @@ -1,5 +1,7 @@ (** Test the interaction between ASSERT prints and the `--verbose` option. *) +module Alcotest = Alcotest.V1 + let () = let open Alcotest in run ~verbose:true "assert-and-verbose" diff --git a/test/e2e/alcotest/passing/assert_not_printed.expected b/test/e2e/alcotest/passing/assert_not_printed.expected index aa5e7104..421fb0e3 100644 --- a/test/e2e/alcotest/passing/assert_not_printed.expected +++ b/test/e2e/alcotest/passing/assert_not_printed.expected @@ -1,9 +1,10 @@ Testing `test/e2e/alcotest/passing/assert_not_printed.ml'. This run has ID `'. - [OK] alpha 0 0. - [OK] alpha 1 1. - [OK] beta 0 2. + [PASS] alpha β€Ί 0 + [PASS] alpha β€Ί 1 + [PASS] beta β€Ί 2 -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 3 tests run. + diff --git a/test/e2e/alcotest/passing/assert_not_printed.ml b/test/e2e/alcotest/passing/assert_not_printed.ml index a81aecb7..0660a4b0 100644 --- a/test/e2e/alcotest/passing/assert_not_printed.ml +++ b/test/e2e/alcotest/passing/assert_not_printed.ml @@ -2,6 +2,8 @@ logs due to Format buffers not being flushed. See https://github.com/mirage/alcotest/pull/228 for details. *) +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let s tc = tc ^ ": SHOULD NOT BE PRINTED" in diff --git a/test/e2e/alcotest/passing/basic.expected b/test/e2e/alcotest/passing/basic.expected index f10d1713..01ab3901 100644 --- a/test/e2e/alcotest/passing/basic.expected +++ b/test/e2e/alcotest/passing/basic.expected @@ -1,10 +1,11 @@ Testing `test/e2e/alcotest/passing/basic.ml'. This run has ID `'. - [OK] test-a 0 First test case. - [OK] test-a 1 Second test case. - [OK] test-b 0 Third test case. - [OK] test-c 0 Fourth test case. + [PASS] test-a β€Ί First test case + [PASS] test-a β€Ί Second test case + [PASS] test-b β€Ί Third test case + [PASS] test-c β€Ί Fourth test case -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 4 tests run. + diff --git a/test/e2e/alcotest/passing/basic.ml b/test/e2e/alcotest/passing/basic.ml index 11300133..3d1ce913 100644 --- a/test/e2e/alcotest/passing/basic.ml +++ b/test/e2e/alcotest/passing/basic.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/check_basic.expected b/test/e2e/alcotest/passing/check_basic.expected index 23aa54ca..447a4abd 100644 --- a/test/e2e/alcotest/passing/check_basic.expected +++ b/test/e2e/alcotest/passing/check_basic.expected @@ -1,30 +1,31 @@ Testing `test/e2e/alcotest/passing/check_basic.ml'. This run has ID `'. - [OK] reflexive basic 0 unit. - [OK] reflexive basic 1 bool. - [OK] reflexive basic 2 int. - [OK] reflexive basic 3 int32. - [OK] reflexive basic 4 int64. - [OK] reflexive basic 5 float. - [OK] reflexive basic 6 char. - [OK] reflexive basic 7 string. - [OK] reflexive basic 8 bytes. - [OK] reflexive composite 0 empty list. - [OK] reflexive composite 1 non-empty list. - [OK] reflexive composite 2 empty array. - [OK] reflexive composite 3 non-empty array. - [OK] reflexive composite 4 option some. - [OK] reflexive composite 5 option none. - [OK] reflexive composite 6 result ok. - [OK] reflexive composite 7 result error. - [OK] reflexive composite 8 pair. - [OK] reflexive composite 9 triple. - [OK] negation 0 checked exceptions. - [OK] negation 1 negated testables. - [OK] fuzzy equality 0 float thresholds. - [OK] fuzzy equality 1 sorted list. - [OK] labeled check 0 passing. + [PASS] reflexive basic β€Ί unit + [PASS] reflexive basic β€Ί bool + [PASS] reflexive basic β€Ί int + [PASS] reflexive basic β€Ί int32 + [PASS] reflexive basic β€Ί int64 + [PASS] reflexive basic β€Ί float + [PASS] reflexive basic β€Ί char + [PASS] reflexive basic β€Ί string + [PASS] reflexive basic β€Ί bytes + [PASS] reflexive composite β€Ί empty list + [PASS] reflexive composite β€Ί non-empty list + [PASS] reflexive composite β€Ί empty array + [PASS] reflexive composite β€Ί non-empty array + [PASS] reflexive composite β€Ί option some + [PASS] reflexive composite β€Ί option none + [PASS] reflexive composite β€Ί result ok + [PASS] reflexive composite β€Ί result error + [PASS] reflexive composite β€Ί pair + [PASS] reflexive composite β€Ί triple + [PASS] negation β€Ί checked exceptions + [PASS] negation β€Ί negated testables + [PASS] fuzzy equality β€Ί float thresholds + [PASS] fuzzy equality β€Ί sorted list + [PASS] labeled check β€Ί passing -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 24 tests run. + diff --git a/test/e2e/alcotest/passing/check_basic.ml b/test/e2e/alcotest/passing/check_basic.ml index 8fc9be7d..217a4def 100644 --- a/test/e2e/alcotest/passing/check_basic.ml +++ b/test/e2e/alcotest/passing/check_basic.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + (* Check that v of type [typ] matches with itself *) let id_case typ typ_str v = Alcotest.test_case typ_str `Quick (fun () -> Alcotest.check typ typ_str v v) diff --git a/test/e2e/alcotest/passing/cli_verbose.expected b/test/e2e/alcotest/passing/cli_verbose.expected index a2153997..ba698d13 100644 --- a/test/e2e/alcotest/passing/cli_verbose.expected +++ b/test/e2e/alcotest/passing/cli_verbose.expected @@ -2,6 +2,7 @@ Testing `cli_verbose'. This run has ID `'. SHOULD APPEAR IN TEST OUTPUT - [OK] alpha 0 0. + [PASS] alpha β€Ί 0 Test Successful in s. 1 test run. + diff --git a/test/e2e/alcotest/passing/cli_verbose.ml b/test/e2e/alcotest/passing/cli_verbose.ml index 956c25d5..5c33aa17 100644 --- a/test/e2e/alcotest/passing/cli_verbose.ml +++ b/test/e2e/alcotest/passing/cli_verbose.ml @@ -1,5 +1,7 @@ (** Ensures that the `--verbose` flag is passed from the CLI. *) +module Alcotest = Alcotest.V1 + let () = let open Alcotest in run ~verbose:false (* CLI flag should take priority over this option *) diff --git a/test/e2e/alcotest/passing/compact.ml b/test/e2e/alcotest/passing/compact.ml index 4aba36bd..1cafbc19 100644 --- a/test/e2e/alcotest/passing/compact.ml +++ b/test/e2e/alcotest/passing/compact.ml @@ -1,4 +1,5 @@ -open Alcotest_engine.Private.Utils +module Alcotest = Alcotest.V1 +open Alcotest_engine.Stdlib_ext let () = let open Alcotest in diff --git a/test/e2e/alcotest/passing/dune.inc b/test/e2e/alcotest/passing/dune.inc index a00cf57b..5a973b31 100644 --- a/test/e2e/alcotest/passing/dune.inc +++ b/test/e2e/alcotest/passing/dune.inc @@ -11,10 +11,12 @@ empty_test_name filter_name filter_name_regex + huge isatty json_output list_tests only_monadic_effects + ppx quick_only quick_only_regex separator_testname @@ -22,6 +24,7 @@ verbose_newlines ) (libraries alcotest alcotest.engine) + (preprocess (pps ppx_alcotest)) (modules and_exit_false and_exit_true @@ -34,10 +37,12 @@ empty_test_name filter_name filter_name_regex + huge isatty json_output list_tests only_monadic_effects + ppx quick_only quick_only_regex separator_testname @@ -255,6 +260,25 @@ (action (diff filter_name_regex.expected filter_name_regex.processed))) +(rule + (target huge.actual) + (action + (with-outputs-to %{target} + (with-accepted-exit-codes (or 0 125) + (run %{dep:huge.exe}))))) + +(rule + (target huge.processed) + (action + (with-outputs-to %{target} + (run ../../strip_randomness.exe %{dep:huge.actual})))) + +(rule + (alias runtest) + (package alcotest) + (action + (diff huge.expected huge.processed))) + (rule (target isatty.actual) (action @@ -331,6 +355,25 @@ (action (diff only_monadic_effects.expected only_monadic_effects.processed))) +(rule + (target ppx.actual) + (action + (with-outputs-to %{target} + (with-accepted-exit-codes (or 0 125) + (run %{dep:ppx.exe}))))) + +(rule + (target ppx.processed) + (action + (with-outputs-to %{target} + (run ../../strip_randomness.exe %{dep:ppx.actual})))) + +(rule + (alias runtest) + (package alcotest) + (action + (diff ppx.expected ppx.processed))) + (rule (target quick_only.actual) (action diff --git a/test/e2e/alcotest/passing/empty_test_name.expected b/test/e2e/alcotest/passing/empty_test_name.expected index dc571a50..b7007cac 100644 --- a/test/e2e/alcotest/passing/empty_test_name.expected +++ b/test/e2e/alcotest/passing/empty_test_name.expected @@ -1,7 +1,8 @@ Testing `test/e2e/alcotest/passing/empty_test_name.ml'. This run has ID `'. - [OK] 0 1. + [PASS] β€Ί 1 -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 1 test run. + diff --git a/test/e2e/alcotest/passing/empty_test_name.ml b/test/e2e/alcotest/passing/empty_test_name.ml index 53fc7420..01a6f5e4 100644 --- a/test/e2e/alcotest/passing/empty_test_name.ml +++ b/test/e2e/alcotest/passing/empty_test_name.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = Alcotest.run __FILE__ [ ("", [ Alcotest.test_case "1" `Quick (fun () -> ()) ]) ] diff --git a/test/e2e/alcotest/passing/filter_name.expected b/test/e2e/alcotest/passing/filter_name.expected index 41f77018..70fac389 100644 --- a/test/e2e/alcotest/passing/filter_name.expected +++ b/test/e2e/alcotest/passing/filter_name.expected @@ -1,9 +1,9 @@ Testing `test/e2e/alcotest/passing/filter_name.ml'. This run has ID `'. - [OK] test-a 0 First test case. - [OK] test-a 1 Second test case. - [SKIP] test-b 0 Skipped failing test. + [PASS] test-a β€Ί First test case + [PASS] test-a β€Ί Second test case + [SKIP] test-b β€Ί Skipped failing test -Full test results in `/_build/_tests/'. +Full test results in `/home/craigfe/t/alcotest/_build/default/test/e2e/alcotest/passing/_build/_tests'. Test Successful in s. 2 tests run. diff --git a/test/e2e/alcotest/passing/filter_name.ml b/test/e2e/alcotest/passing/filter_name.ml index f7ac657b..3bf59202 100644 --- a/test/e2e/alcotest/passing/filter_name.ml +++ b/test/e2e/alcotest/passing/filter_name.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/filter_name_regex.expected b/test/e2e/alcotest/passing/filter_name_regex.expected index e55dfd86..125c8939 100644 --- a/test/e2e/alcotest/passing/filter_name_regex.expected +++ b/test/e2e/alcotest/passing/filter_name_regex.expected @@ -1,11 +1,11 @@ Testing `test/e2e/alcotest/passing/filter_name_regex.ml'. This run has ID `'. - [OK] basic-run-a 0 Executed. - [OK] basic-run-a 1 Also executed. - [SKIP] basic-run-b 0 Skipped. - [OK] basic-run-c 0 Executed. - [SKIP] complex-run-a 0 Skipped. + [PASS] basic-run-a β€Ί Executed + [PASS] basic-run-a β€Ί Also executed + [SKIP] basic-run-b β€Ί Skipped + [PASS] basic-run-c β€Ί Executed + [SKIP] complex-run-a β€Ί Skipped -Full test results in `/_build/_tests/'. +Full test results in `/home/craigfe/t/alcotest/_build/default/test/e2e/alcotest/passing/_build/_tests'. Test Successful in s. 3 tests run. diff --git a/test/e2e/alcotest/passing/filter_name_regex.ml b/test/e2e/alcotest/passing/filter_name_regex.ml index 95a369d4..83cbbc6b 100644 --- a/test/e2e/alcotest/passing/filter_name_regex.ml +++ b/test/e2e/alcotest/passing/filter_name_regex.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/huge.expected b/test/e2e/alcotest/passing/huge.expected new file mode 100644 index 00000000..3e625c80 --- /dev/null +++ b/test/e2e/alcotest/passing/huge.expected @@ -0,0 +1,17 @@ +Testing `test/e2e/alcotest/passing/huge.ml'. +This run has ID `'. + + [PASS] alpha β€Ί 0 + [PASS] alpha β€Ί 1 + [PASS] alpha β€Ί 2 + [PASS] alpha β€Ί 3 + [PASS] alpha β€Ί 4 + [PASS] alpha β€Ί 5 + [PASS] alpha β€Ί 6 + [PASS] alpha β€Ί 7 + [PASS] alpha β€Ί 8 + [PASS] alpha β€Ί 9 + +Full test results in `/_build/_tests/'. +Test Successful in s. 10 tests run. + diff --git a/test/e2e/alcotest/passing/huge.ml b/test/e2e/alcotest/passing/huge.ml new file mode 100644 index 00000000..a971bdf2 --- /dev/null +++ b/test/e2e/alcotest/passing/huge.ml @@ -0,0 +1,31 @@ +module Alcotest = Alcotest.V1 + +let pid = Unix.getpid () + +let read_all_lines ic = + let acc = ref [] in + try + while true do + acc := input_line ic :: !acc + done; + assert false + with End_of_file -> String.concat "\n" !acc + +let test_case n () = + let open_fds = + let ic = + Unix.open_process_in ("lsof -p " ^ string_of_int pid ^ " 2>/dev/null") + in + let t = read_all_lines ic in + close_in ic; + t + in + Printf.printf "Test #%d. File descriptors open: %s\n%!" n open_fds + +let () = + Alcotest.run __FILE__ + [ + ( "alpha", + List.init 10 (fun i -> + Alcotest.test_case (string_of_int i) `Quick (test_case i)) ); + ] diff --git a/test/e2e/alcotest/passing/isatty.expected b/test/e2e/alcotest/passing/isatty.expected index 7ed7bc98..7db2c3dc 100644 --- a/test/e2e/alcotest/passing/isatty.expected +++ b/test/e2e/alcotest/passing/isatty.expected @@ -1,10 +1,11 @@ Testing `test/e2e/alcotest/passing/isatty.ml'. This run has ID `'. - ... test-a 0 First test case. [OK] test-a 0 First test case. - ... test-a 1 Second test case. [OK] test-a 1 Second test case. - ... test-b 0 Third test case. [OK] test-b 0 Third test case. - ... test-c 0 Fourth test case. [OK] test-c 0 Fourth test case. + [ β€”β€” ] test-a β€Ί First test case [PASS] test-a β€Ί First test case + [ β€”β€” ] test-a β€Ί Second test case [PASS] test-a β€Ί Second test case + [ β€”β€” ] test-b β€Ί Third test case [PASS] test-b β€Ί Third test case + [ β€”β€” ] test-c β€Ί Fourth test case [PASS] test-c β€Ί Fourth test case -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 4 tests run. + diff --git a/test/e2e/alcotest/passing/isatty.ml b/test/e2e/alcotest/passing/isatty.ml index 4270e011..05779be8 100644 --- a/test/e2e/alcotest/passing/isatty.ml +++ b/test/e2e/alcotest/passing/isatty.ml @@ -8,7 +8,7 @@ module Platform (M : Alcotest_engine.Monad.S) = struct end module Alcotest = - Alcotest_engine.Core.Make (Platform) (Alcotest_engine.Monad.Identity) + Alcotest_engine.Core.Make_v1 (Platform) (Alcotest_engine.Monad.Identity) let () = let open Alcotest in diff --git a/test/e2e/alcotest/passing/json_output.ml b/test/e2e/alcotest/passing/json_output.ml index 874d7186..5e82700c 100644 --- a/test/e2e/alcotest/passing/json_output.ml +++ b/test/e2e/alcotest/passing/json_output.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/list_tests.expected b/test/e2e/alcotest/passing/list_tests.expected index de275e29..75cf33d7 100644 --- a/test/e2e/alcotest/passing/list_tests.expected +++ b/test/e2e/alcotest/passing/list_tests.expected @@ -1,3 +1,8 @@ -test-a 0 alpha. -test-a 1 beta. -test-b 0 lorem ipsum dolor sit amet consectutor adipiscing elit. +test/e2e/alcotest/passing/list_tests.ml +β”œβ”€ test-a +β”‚ β”œβ”€ alpha < speed_level = Quick; index = 0 > +β”‚ └─ beta < speed_level = Quick; index = 1 > +β”‚ +└─ test-b + └─ lorem ipsum dolor sit amet consectutor adipiscing elit < speed_level = Quick; index = 0 > + diff --git a/test/e2e/alcotest/passing/list_tests.ml b/test/e2e/alcotest/passing/list_tests.ml index 740a5d52..b2eb7f13 100644 --- a/test/e2e/alcotest/passing/list_tests.ml +++ b/test/e2e/alcotest/passing/list_tests.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let failtest () = invalid_arg "This test should never be run" in diff --git a/test/e2e/alcotest/passing/only_monadic_effects.ml b/test/e2e/alcotest/passing/only_monadic_effects.ml index 52e127e7..063d365a 100644 --- a/test/e2e/alcotest/passing/only_monadic_effects.ml +++ b/test/e2e/alcotest/passing/only_monadic_effects.ml @@ -22,7 +22,7 @@ module Terminal : Alcotest_engine.Monad.S = struct let catch f on_error = match f () with x -> x | exception ex -> on_error ex end -module Runner = Alcotest_engine.Core.Make (Alcotest.Unix) (Terminal) +module Runner = Alcotest_engine.Core.Make_v1 (Alcotest.Unix) (Terminal) let () = let (_ : unit Terminal.t) = diff --git a/test/e2e/alcotest/passing/ppx.expected b/test/e2e/alcotest/passing/ppx.expected new file mode 100644 index 00000000..8226c3fd --- /dev/null +++ b/test/e2e/alcotest/passing/ppx.expected @@ -0,0 +1,12 @@ + +Testing `test/e2e/alcotest/passing/ppx.ml'. +This run has ID `'. + + [PASS] Lorem β€Ί ipsum + [PASS] Lorem β€Ί dolor + [PASS] Sit β€Ί Amet β€Ί consectetur + [PASS] Sit β€Ί adipiscing + +Full test results in `/_build/_tests/'. +Test Successful in s. 4 tests run. + diff --git a/test/e2e/alcotest/passing/ppx.ml b/test/e2e/alcotest/passing/ppx.ml new file mode 100644 index 00000000..4ca84879 --- /dev/null +++ b/test/e2e/alcotest/passing/ppx.ml @@ -0,0 +1,16 @@ +module%test Lorem = struct + let%test "ipsum" = () + let%test "dolor" = () +end + +module%test Sit = struct + module%test Amet = struct + let%test "consectetur" = () + end + + let%test "adipiscing" = () +end + +let () = print_endline "" + +[%%run_tests] diff --git a/test/e2e/alcotest/passing/quick_only.expected b/test/e2e/alcotest/passing/quick_only.expected index f83811f6..d5532fe0 100644 --- a/test/e2e/alcotest/passing/quick_only.expected +++ b/test/e2e/alcotest/passing/quick_only.expected @@ -1,10 +1,11 @@ Testing `test/e2e/alcotest/passing/quick_only.ml'. This run has ID `'. - [OK] test-a 0 Quick. - [SKIP] test-a 1 Slow. - [SKIP] test-b 0 Slow. - [OK] test-b 1 Quick. + [PASS] test-a β€Ί Quick + [SKIP] test-a β€Ί Slow + [SKIP] test-b β€Ί Slow + [PASS] test-b β€Ί Quick -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 2 tests run. + diff --git a/test/e2e/alcotest/passing/quick_only.ml b/test/e2e/alcotest/passing/quick_only.ml index 7fe5c899..e682caae 100644 --- a/test/e2e/alcotest/passing/quick_only.ml +++ b/test/e2e/alcotest/passing/quick_only.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/quick_only_regex.expected b/test/e2e/alcotest/passing/quick_only_regex.expected index f8ec3441..cf81d299 100644 --- a/test/e2e/alcotest/passing/quick_only_regex.expected +++ b/test/e2e/alcotest/passing/quick_only_regex.expected @@ -1,10 +1,10 @@ Testing `test/e2e/alcotest/passing/quick_only_regex.ml'. This run has ID `'. - [OK] test-a 0 Quick & passes filter. - [SKIP] test-a 1 Slow & passes filter. - [SKIP] test-b 0 Slow & fails filter. - [SKIP] test-b 1 Quick & fails filter. + [PASS] test-a β€Ί Quick & passes filter + [SKIP] test-a β€Ί Slow & passes filter + [SKIP] test-b β€Ί Slow & fails filter + [SKIP] test-b β€Ί Quick & fails filter -Full test results in `/_build/_tests/'. +Full test results in `/home/craigfe/t/alcotest/_build/default/test/e2e/alcotest/passing/_build/_tests'. Test Successful in s. 1 test run. diff --git a/test/e2e/alcotest/passing/quick_only_regex.ml b/test/e2e/alcotest/passing/quick_only_regex.ml index 825aa9b9..1a659c5e 100644 --- a/test/e2e/alcotest/passing/quick_only_regex.ml +++ b/test/e2e/alcotest/passing/quick_only_regex.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = let open Alcotest in let id () = () in diff --git a/test/e2e/alcotest/passing/separator_testname.expected b/test/e2e/alcotest/passing/separator_testname.expected index dd0b49cf..6128ac5b 100644 --- a/test/e2e/alcotest/passing/separator_testname.expected +++ b/test/e2e/alcotest/passing/separator_testname.expected @@ -1,7 +1,8 @@ Testing `test/e2e/alcotest/passing/separator_testname.ml'. This run has ID `'. - [OK] with/separator 0 First test case. + [PASS] with/separator β€Ί First test case -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 1 test run. + diff --git a/test/e2e/alcotest/passing/separator_testname.ml b/test/e2e/alcotest/passing/separator_testname.ml index 734d16fc..0461c1ef 100644 --- a/test/e2e/alcotest/passing/separator_testname.ml +++ b/test/e2e/alcotest/passing/separator_testname.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = Alcotest.run __FILE__ [ diff --git a/test/e2e/alcotest/passing/unicode_testname.expected b/test/e2e/alcotest/passing/unicode_testname.expected index 94336ba3..3ee4e614 100644 --- a/test/e2e/alcotest/passing/unicode_testname.expected +++ b/test/e2e/alcotest/passing/unicode_testname.expected @@ -1,8 +1,9 @@ Testing `Suite name containing file separators / and non-ASCII characters πŸ”₯'. This run has ID `'. - [OK] πŸ”₯ 0 Non ASCII unicode character. - [OK] πŸ”₯a-b 0 Non ASCII and ASCII characters. + [PASS] πŸ”₯ β€Ί Non ASCII unicode character + [PASS] πŸ”₯a-b β€Ί Non ASCII and ASCII characters -Full test results in `/_build/_tests/'. +Full test results in `/_build/_tests/'. Test Successful in s. 2 tests run. + diff --git a/test/e2e/alcotest/passing/unicode_testname.ml b/test/e2e/alcotest/passing/unicode_testname.ml index 70370a77..c935aae4 100644 --- a/test/e2e/alcotest/passing/unicode_testname.ml +++ b/test/e2e/alcotest/passing/unicode_testname.ml @@ -1,3 +1,5 @@ +module Alcotest = Alcotest.V1 + let () = Alcotest.run "Suite name containing file separators / and non-ASCII characters πŸ”₯" diff --git a/test/e2e/alcotest/passing/verbose_newlines.expected b/test/e2e/alcotest/passing/verbose_newlines.expected index 86ca0f9d..d22b0938 100644 --- a/test/e2e/alcotest/passing/verbose_newlines.expected +++ b/test/e2e/alcotest/passing/verbose_newlines.expected @@ -1,13 +1,14 @@ Testing `test/e2e/alcotest/passing/verbose_newlines.ml'. This run has ID `'. -Print inside alpha [OK] alpha 0 0 newlines. +Print inside alpha [PASS] alpha β€Ί 0 newlines Print inside beta - [OK] beta 0 1 newline. + [PASS] beta β€Ί 1 newline Print inside gamma -Lorem ipsum dolor sit amet, consectetur adipiscing elit, nullam malesuada dictum tortor in venenatis. [OK] gamma 0 1 newline + long line. +Lorem ipsum dolor sit amet, consectetur adipiscing elit, nullam malesuada dictum tortor in venenatis. [PASS] gamma β€Ί 1 newline + long line Print inside delta ASSERT Lorem ipsum dolor sit amet, consectetur adipiscing elit, nullam malesuada dictum tortor in venenatis. - [OK] delta 0 1 newline + long check. + [PASS] delta β€Ί 1 newline + long check Test Successful in s. 4 tests run. + diff --git a/test/e2e/alcotest/passing/verbose_newlines.ml b/test/e2e/alcotest/passing/verbose_newlines.ml index 36aed1ba..08ae64a5 100644 --- a/test/e2e/alcotest/passing/verbose_newlines.ml +++ b/test/e2e/alcotest/passing/verbose_newlines.ml @@ -1,6 +1,8 @@ (** Reproduction for https://github.com/mirage/alcotest/issues/225, testing the interaction between `--verbose` and newlines in the test stdout. *) +module Alcotest = Alcotest.V1 + let () = Alcotest.run ~verbose:true __FILE__ [ diff --git a/test/e2e/gen_dune_rules.ml b/test/e2e/gen_dune_rules.ml index e300e35b..6956499b 100644 --- a/test/e2e/gen_dune_rules.ml +++ b/test/e2e/gen_dune_rules.ml @@ -44,6 +44,7 @@ let global_stanza ~libraries filenames = %a ) (libraries alcotest%a) + (preprocess (pps ppx_alcotest)) (modules %a ) @@ -101,7 +102,9 @@ let example_alias_stanza ~package filename = |} package base base -let is_example filename = Filename.check_suffix filename ".ml" +let is_example filename = + Filename.check_suffix filename ".ml" + && not (Filename.check_suffix filename ".pp.ml") let main package expect_failure libraries = Sys.readdir "." diff --git a/test/e2e/strip_randomness.ml b/test/e2e/strip_randomness.ml index d3a1714d..cf8b30e4 100644 --- a/test/e2e/strip_randomness.ml +++ b/test/e2e/strip_randomness.ml @@ -38,14 +38,11 @@ let build_context_replace = let uuid_replace = let open Re in - let hex n = repn (alt [ rg 'A' 'F'; digit ]) n (Some n) in - let segmented_hex ns = - let segments = List.map (fun n -> [ char '-'; hex n ]) ns in - List.flatten segments |> List.tl |> seq + let t = + seq [ str "ID `"; repn (alt [ rg 'A' 'Z'; digit ]) 8 (Some 8); char '\'' ] in - let t = segmented_hex [ 8; 4; 4; 4; 12 ] in let re = compile t in - replace_string ~all:true re ~by:"" + replace_string ~all:true re ~by:"ID `'" let time_replace = let open Re in diff --git a/test/ppx/dune b/test/ppx/dune new file mode 100644 index 00000000..31240cb4 --- /dev/null +++ b/test/ppx/dune @@ -0,0 +1,8 @@ +(executable + (name gen_dune_rules) + (modules gen_dune_rules)) + +(executable + (name pp) + (modules pp) + (libraries ppx_alcotest ppxlib)) diff --git a/test/ppx/errors/bad_test_payload.expected b/test/ppx/errors/bad_test_payload.expected new file mode 100644 index 00000000..c88cc1f6 --- /dev/null +++ b/test/ppx/errors/bad_test_payload.expected @@ -0,0 +1,2 @@ +File "bad_test_payload.ml", line 1, characters 9-10: +Error: Unsupported test name type. Use a literal string or an integer. diff --git a/test/ppx/errors/bad_test_payload.ml b/test/ppx/errors/bad_test_payload.ml new file mode 100644 index 00000000..ce122a85 --- /dev/null +++ b/test/ppx/errors/bad_test_payload.ml @@ -0,0 +1 @@ +let%test x = () diff --git a/test/ppx/errors/dune b/test/ppx/errors/dune new file mode 100644 index 00000000..2be6b1da --- /dev/null +++ b/test/ppx/errors/dune @@ -0,0 +1,16 @@ +(include dune.inc) + +(rule + (targets dune.inc.gen) + (deps + (source_tree .)) + (action + (with-stdout-to + %{targets} + (run ../gen_dune_rules.exe --expect-failure)))) + +(rule + (alias runtest) + (package ppx_alcotest) + (action + (diff dune.inc dune.inc.gen))) diff --git a/test/ppx/errors/dune.inc b/test/ppx/errors/dune.inc new file mode 100644 index 00000000..b0ac4076 --- /dev/null +++ b/test/ppx/errors/dune.inc @@ -0,0 +1,30 @@ +(env + (_ + (env-vars + (OCAML_ERROR_STYLE "short") + (OCAML_COLOR "never")))) + +; -------- Test: `bad_test_payload.ml` -------- + + + +; Run the PPX on the `.ml` file +(rule + (targets bad_test_payload.actual) + (deps + (:pp ../pp.exe) + (:input bad_test_payload.ml)) + (action + ; expect the process to fail, capturing stderr + (with-stderr-to + %{targets} + (bash "! %{pp} -no-color --impl %{input}")))) + +; Compare the post-processed output to the .expected file +(rule + (alias runtest) + (package ppx_alcotest) + (action + (diff bad_test_payload.expected bad_test_payload.actual))) + + diff --git a/test/ppx/gen_dune_rules.ml b/test/ppx/gen_dune_rules.ml new file mode 100644 index 00000000..816e519d --- /dev/null +++ b/test/ppx/gen_dune_rules.ml @@ -0,0 +1,96 @@ +(* Global configuration for tests in which the PPX fails (for consistency with + various compiler versions / platforms). *) +let ppx_fail_global_stanzas () = + Format.printf + {|(env + (_ + (env-vars + (OCAML_ERROR_STYLE "short") + (OCAML_COLOR "never")))) + +|} + +let output_stanzas ~expect_failure filename = + let base = Filename.remove_extension filename in + let pp_library ppf base = + (* If the PPX will fail, we don't need to declare the file as executable *) + if not expect_failure then + Format.fprintf ppf + "; The PPX-dependent executable under test@,\ + @[(executable@ (name %s)@ (modules %s)@ (preprocess (pps \ + ppx_alcotest))@ (libraries alcotest))@]" + base base + else () + in + let pp_rule ppf base = + let pp_action ppf expect_failure = + Format.fprintf ppf + (if expect_failure then + "; expect the process to fail, capturing stderr@,\ + @[(with-stderr-to@,\ + %%{targets}@,\ + (bash \"! %%{pp} -no-color --impl %%{input}\"))@]" + else "(run %%{pp} --impl %%{input} -o %%{targets})") + in + Format.fprintf ppf + "; Run the PPX on the `.ml` file@,\ + @[(rule@,\ + (targets %s.actual)@,\ + @[(deps@,\ + (:pp ../pp.exe)@,\ + (:input %s.ml))@]@,\ + @[(action@,\ + %a))@]@]" + base base pp_action expect_failure + in + let pp_diff_alias ppf base = + Format.fprintf ppf + "; Compare the post-processed output to the .expected file@,\ + @[(rule@,\ + (alias runtest)@,\ + (package ppx_alcotest)@,\ + @[(action@,\ + @[(diff@ %s.expected@ %s.actual)@])@])@]" base base + in + let pp_run_alias ppf base = + (* If we expect the derivation to succeed, then we should be able to compile + the output. *) + if not expect_failure then + Format.fprintf ppf + "@,\ + @,\ + ; Ensure that the post-processed executable runs correctly@,\ + @[(rule@,\ + (alias runtest)@,\ + (package ppx_alcotest)@,\ + @[(action@,\ + @[(run@ ./%s.exe)@])@])@]" base + else () + in + Format.set_margin 80; + Format.printf + "@[; -------- Test: `%s.ml` --------@,@,%a@,@,%a@,@,%a%a@,@]@." base + pp_library base pp_rule base pp_diff_alias base pp_run_alias base + +let is_error_test = function + | "pp.ml" -> false + | "gen_dune_rules.ml" -> false + | filename -> + Filename.check_suffix filename ".ml" + (* Avoid capturing post-PPX files *) + && not (Filename.check_suffix filename ".pp.ml") + +let () = + let expect_failure = + match Array.to_list Sys.argv with + | [ _; "--expect-failure" ] -> true + | [ _ ] -> false + | _ -> failwith "Unsupported option passed" + in + if expect_failure then ppx_fail_global_stanzas (); + Sys.readdir "." + |> Array.to_list + |> List.sort String.compare + |> List.filter is_error_test + |> List.iter (output_stanzas ~expect_failure); + Format.printf "\n%!" diff --git a/test/ppx/passing/alias.expected b/test/ppx/passing/alias.expected new file mode 100644 index 00000000..5a7ce0c2 --- /dev/null +++ b/test/ppx/passing/alias.expected @@ -0,0 +1,15 @@ +let _ = + { Lexing.pos_fname = "alias.ml"; pos_lnum = 1; pos_cnum = 8; pos_bol = 0 } +let _ = + fun ?(here= + { + Lexing.pos_fname = "alias.ml"; + pos_lnum = 3; + pos_cnum = 25; + pos_bol = 17 + }) -> + fun ?msg -> + fun ~expected -> + fun actual -> + Ppx_alcotest_runtime.check ~here + ~testable:(Alcotest.list Alcotest.int) ?msg ~expected actual diff --git a/test/ppx/passing/alias.ml b/test/ppx/passing/alias.ml new file mode 100644 index 00000000..d30a18b8 --- /dev/null +++ b/test/ppx/passing/alias.ml @@ -0,0 +1,2 @@ +let _ = [%here] +let _ = [%check: int list] diff --git a/test/ppx/passing/dune b/test/ppx/passing/dune new file mode 100644 index 00000000..f1670d96 --- /dev/null +++ b/test/ppx/passing/dune @@ -0,0 +1,16 @@ +(include dune.inc) + +(rule + (targets dune.inc.gen) + (deps + (source_tree .)) + (action + (with-stdout-to + %{targets} + (run ../gen_dune_rules.exe)))) + +(rule + (alias runtest) + (package ppx_alcotest) + (action + (diff dune.inc dune.inc.gen))) diff --git a/test/ppx/passing/dune.inc b/test/ppx/passing/dune.inc new file mode 100644 index 00000000..cb35d5d4 --- /dev/null +++ b/test/ppx/passing/dune.inc @@ -0,0 +1,33 @@ +; -------- Test: `alias.ml` -------- + +; The PPX-dependent executable under test +(executable + (name alias) + (modules alias) + (preprocess (pps ppx_alcotest)) + (libraries alcotest)) + +; Run the PPX on the `.ml` file +(rule + (targets alias.actual) + (deps + (:pp ../pp.exe) + (:input alias.ml)) + (action + (run %{pp} --impl %{input} -o %{targets}))) + +; Compare the post-processed output to the .expected file +(rule + (alias runtest) + (package ppx_alcotest) + (action + (diff alias.expected alias.actual))) + +; Ensure that the post-processed executable runs correctly +(rule + (alias runtest) + (package ppx_alcotest) + (action + (run ./alias.exe))) + + diff --git a/test/ppx/pp.ml b/test/ppx/pp.ml new file mode 100644 index 00000000..e3cba404 --- /dev/null +++ b/test/ppx/pp.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone ()