From 012ace98b153d910c5615122d4937e0e992a706f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Thu, 24 Feb 2022 18:18:44 +0100 Subject: [PATCH] Port Lwttester to Alcotest [Alcotest][] is "a lightweight and colourful test framework". It provides benefits over Lwt's current lwttester: it allows selecting which test cases and test suites to run, has a colorful logging, better integration with dune and standalone testing, and better logging overall. Porting the whole test suite was deemed too complex without code-rewriting tools, so only Lwt's Test library was re-implemented on top of Alcotest. We can revisit that later. 1. The main caveat is that Alcotest has no support for running tests concurrently, so the whole run is slightly longer. 2. Another problem is that alcotest-lwt re-exports lwt.unix which causes circular dependencies, so version alcotest-lwt.1.5.0 was embedded. 3. Usage of the Skip exception to skip a test while it's running cannot be ported to Alcotest too. 4. Alcotest requires OCaml >= 4.05. We keep the old test suite for OCaml < 4.05. --- lwt.opam | 4 +- lwt_luv.opam | 2 + lwt_react.opam | 2 + test/dune | 5 +- test/test_alcotest.ml | 168 ++++++++++++++++++++++++++++++++++ test/{test.ml => test_lwt.ml} | 0 6 files changed, 179 insertions(+), 2 deletions(-) create mode 100644 test/test_alcotest.ml rename test/{test.ml => test_lwt.ml} (100%) diff --git a/lwt.opam b/lwt.opam index 3c097fc8fc..10e40c46c5 100644 --- a/lwt.opam +++ b/lwt.opam @@ -19,7 +19,7 @@ maintainer: [ dev-repo: "git+https://github.com/ocsigen/lwt.git" depends: [ - "cppo" {build & >= "1.1.0"} + "cppo" {build & with-test & >= "1.1.0"} "dune" {>= "1.8.0"} "dune-configurator" "mmap" {>= "1.1.0" & "os" != "win32"} # mmap is needed as long as Lwt supports OCaml < 4.06.0. @@ -31,6 +31,8 @@ depends: [ # Until https://github.com/aantron/bisect_ppx/pull/327. # "bisect_ppx" {dev & >= "2.0.0"} "ocamlfind" {dev & >= "1.7.3-1"} + + "alcotest" {with-test & >= "1.5.0" & "ocaml" >= "4.05"} ] depopts: [ diff --git a/lwt_luv.opam b/lwt_luv.opam index caa0d633fa..7a8e9b3c8a 100644 --- a/lwt_luv.opam +++ b/lwt_luv.opam @@ -22,6 +22,8 @@ depends: [ # Until https://github.com/aantron/bisect_ppx/pull/327. # "bisect_ppx" {dev & >= "2.0.0"} + + "alcotest" {with-test & >= "1.5.0" & "ocaml" >= "4.05"} ] build: [ diff --git a/lwt_react.opam b/lwt_react.opam index c7e4622ccc..e8c17d51ee 100644 --- a/lwt_react.opam +++ b/lwt_react.opam @@ -21,6 +21,8 @@ depends: [ "lwt" {>= "3.0.0"} "ocaml" "react" {>= "1.0.0"} + + "alcotest" {with-test & >= "1.5.0" & "ocaml" >= "4.05"} ] build: [ diff --git a/test/dune b/test/dune index bee204a1b9..815aa0dfe8 100644 --- a/test/dune +++ b/test/dune @@ -1,4 +1,7 @@ (library (name lwttester) (wrapped false) - (libraries lwt unix lwt.unix)) + (libraries lwt unix lwt.unix + (select test.ml from + (alcotest -> test_alcotest.ml) + ( -> test_lwt.ml)))) diff --git a/test/test_alcotest.ml b/test/test_alcotest.ml new file mode 100644 index 0000000000..72e8b9ca74 --- /dev/null +++ b/test/test_alcotest.ml @@ -0,0 +1,168 @@ +(* This file is part of Lwt, released under the MIT license. See LICENSE.md for + details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *) + +exception Skip + +type test = { + test_name : string; + skip_if_this_is_false : unit -> bool; + sequential : bool; (* Sequential is ignored in Alcotest *) + run : [`Lwt of unit -> bool Lwt.t | `Direct of unit -> bool ]; + } + +let test_direct test_name ?(only_if = fun () -> true) run = + { test_name; skip_if_this_is_false = only_if; sequential = false; run = `Direct run; } + +let test test_name ?(only_if = fun () -> true) ?(sequential = false) run = + { test_name; skip_if_this_is_false = only_if; sequential; run = `Lwt run; } + + +(* Alcotest_lwt 1.5.0 + * + * Copyright (c) 2017 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +*) + +module Alcotest_lwt_intf = struct + module type V1 = sig + include Alcotest_engine.V1.Cli.S with type return = unit Lwt.t + + val test_case : + string -> + Alcotest.speed_level -> + (Lwt_switch.t -> 'a -> unit Lwt.t) -> + 'a test_case + + val test_case_sync : + string -> Alcotest.speed_level -> ('a -> unit) -> 'a test_case + end + + module type Alcotest_lwt = sig + include V1 + + (** {1 Versioned APIs} *) + + module V1 : V1 + (** An alias of the above API that provides a stability guarantees over major + version changes. *) + end +end + +module Alcotest_lwt : sig + include Alcotest_lwt_intf.Alcotest_lwt +end = struct + let run_test fn args = + let async_ex, async_waker = Lwt.wait () in + let handle_exn ex = + Printf.eprintf "Uncaught async exception: %s\n%s" (Printexc.to_string ex) (Printexc.get_backtrace ()); + 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 V1 = struct + module Tester = Alcotest_engine.V1.Cli.Make (Alcotest.Unix_platform) (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 + + include V1 +end + + +let fold_left_map f accu l = + let rec aux accu l_accu = function + | [] -> accu, List.rev l_accu + | x :: l -> + let accu, x = f accu x in + aux accu (x :: l_accu) l in + aux accu [] l + +let fold_left_mapi f accu l = + let rec aux i accu l_accu = function + | [] -> accu, List.rev l_accu + | x :: l -> + let accu, x = f i accu x in + aux (i + 1) accu (x :: l_accu) l in + aux 0 accu [] l + + +open Lwt.Infix + +type suite = { + suite_name : string; + suite_tests : unit Alcotest_lwt.test_case list; + skip_suite_if_this_is_false : unit -> bool; + skip_indexes : int list; +} + +let suite name ?(only_if = fun () -> true) tests = + let to_test_case test = + match test.run with + | `Lwt run -> + Alcotest_lwt.test_case test.test_name `Quick (fun _switch () -> + run () >|= fun b -> + Alcotest.(check bool) "success" b true) + | `Direct run -> + Alcotest_lwt.test_case_sync test.test_name `Quick (fun () -> + let b = run () in + Alcotest.(check bool) "success" b true) + in + let skip_indexes, tests = + fold_left_mapi (fun i skip_indexes test -> + if test.skip_if_this_is_false () then skip_indexes, to_test_case test + else i :: skip_indexes, to_test_case test) + [] (tests : test list) + in + {suite_name = name; + suite_tests = tests; + skip_suite_if_this_is_false = only_if; + skip_indexes} + +let run library_name suites = + let skip = Hashtbl.create 16 in + let skip_names, tests = + fold_left_map (fun skip_names suite -> + if suite.skip_suite_if_this_is_false () then + begin + Hashtbl.add skip suite.suite_name suite.skip_indexes; + skip_names, (suite.suite_name, suite.suite_tests) + end + else + suite.suite_name :: skip_names, (suite.suite_name, suite.suite_tests)) + [] suites in + let filter ~name ~index = + if List.mem name skip_names then `Skip + else + let skip_indexes = Hashtbl.find skip name in + if List.mem index skip_indexes then `Skip + else `Run + in + Alcotest_lwt.run ~filter library_name tests + +let run library_name suites = Lwt_main.run @@ run library_name suites +let concurrent = run + +let with_async_exception_hook hook f = + let old_hook = !Lwt.async_exception_hook in + Lwt.async_exception_hook := hook; + Lwt.finalize f (fun () -> + Lwt.async_exception_hook := old_hook; + Lwt.return ()) + +let instrument = function + | true -> Printf.ksprintf (fun _s -> true) + | false -> Printf.ksprintf (fun s -> prerr_endline ("\n" ^ s); false) diff --git a/test/test.ml b/test/test_lwt.ml similarity index 100% rename from test/test.ml rename to test/test_lwt.ml