[RFC] A nestable test API for Alcotest

alcotest.opam

@@ -20,7 +20,7 @@ doc: "https://mirage.github.io/alcotest"
 bug-reports: "https://github.com/mirage/alcotest/issues"
 depends: [
   "dune" {>= "2.8"}
-  "ocaml" {>= "4.05.0"}
+  "ocaml" {>= "4.06.0"}
   "fmt" {>= "0.8.7"}
   "astring"
   "cmdliner" {>= "1.0.0" & < "1.1.0"}

dune-project

@@ -24,7 +24,7 @@ inspect), with a simple (yet expressive) query language to select the
 tests to run.
 ")
  (depends
-  (ocaml (>= 4.05.0))
+  (ocaml (>= 4.06.0))
   (fmt (>= 0.8.7))
   astring
   (cmdliner (and (>= 1.0.0) (< 1.1.0)))

src/alcotest-async/alcotest_async.ml

@@ -30,3 +30,16 @@ module V1 = struct
 end
 
 include V1
+
+module Unstable = struct
+  module Tester =
+    Alcotest_engine.Unstable.Cli.Make (Alcotest.Unix_platform) (Promise)
+
+  include Tester
+
+  let test_sync ?pos ?tags ~name fn =
+    test ?pos ?tags ~name (fun x -> Deferred.return (fn x))
+
+  let test ?(timeout = sec 2.) ?pos ?tags ~name fn =
+    test ?pos ?tags ~name (run_test timeout name fn)
+end

src/alcotest-async/alcotest_async_intf.ml

@@ -21,4 +21,22 @@ module type Alcotest_async = sig
   module V1 : V1
   (** An alias of the above API that provides a stability guarantees over major
       version changes. *)
+
+  module Unstable : sig
+    open Alcotest_engine.Unstable
+
+    include
+      Core.S
+        with type 'a m := 'a Async_kernel.Deferred.t
+         and type 'a test_args := 'a
+         and type config := Config.User.t
+         and type source_code_position := Source_code_position.pos
+         and type tag_set := Tag.Set.t
+
+    val test :
+      ?timeout:Core_kernel.Time.Span.t ->
+      (('a -> unit Async_kernel.Deferred.t) -> 'a test) Core.identified
+
+    val test_sync : (('a -> unit) -> 'a test) Core.identified
+  end
 end

src/alcotest-async/dune

@@ -3,6 +3,7 @@
  (public_name alcotest-async)
  (libraries
   alcotest.engine
+  alcotest.stdlib_ext
   alcotest
   async_kernel
   async_unix

src/alcotest-engine/alcotest_engine.ml

@@ -1,9 +1,21 @@
+open! Import
+
 module V1 = struct
   module Test = Test
   module Core = Core.V1
   module Cli = Cli.V1
 end
 
+module Unstable = struct
+  module Cli = Cli.Unstable
+  module Config = Config
+  module Core = Core.Unstable
+  module Filter = Filter
+  module Source_code_position = Source_code_position
+  module Tag = Tag
+  module Test = Test
+end
+
 module Monad = Monad
 module Platform = Platform
 

src/alcotest-engine/alcotest_engine.mli

@@ -20,6 +20,8 @@
     to defined tests. The platform-specific runners for these tests are in
     [alcotest], [alcotest-lwt], [alcotest-async] and [alcotest-mirage]. *)
 
+open! Import
+
 module V1 : sig
   (** Version 1 of the user-facing Alcotest API. *)
 
@@ -43,6 +45,18 @@ module V1 : sig
   (** Wraps {!Core} to provide a command-line interface. *)
 end
 
+module Unstable : sig
+  module Test = Test
+  (** Unstable version of the user-facing Alcotest API. *)
+
+  module Core = Core.Unstable
+  module Cli = Cli.Unstable
+  module Tag = Tag
+  module Filter = Filter
+  module Config = Config
+  module Source_code_position = Source_code_position
+end
+
 module Monad = Monad
 (** Monad signatures for use with {!V1.Core} and {!V1.Cli}. *)
 

src/alcotest-engine/cli.ml

@@ -18,116 +18,162 @@
 include Cli_intf
 open! Import
 open Cmdliner
+open Cmdliner_syntax
 
-module Make (P : Platform.MAKER) (M : Monad.S) :
-  V1_types.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}. *)
+let set_color (module Platform : Platform.S) =
+  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 =
+      Fmt.str
+        "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
+  Platform.setup_std_outputs ?style_renderer ()
 
-  module C = Core.V1.Make (P) (M)
-  include C
+module Make (P : Platform.MAKER) (M : Monad.S) = struct
+  module C = Core.Unstable.Make (P) (M)
   module P = P (M)
+  include C
   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 =
-        Fmt.str
-          "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")
+  let run ?pos ?(config = Config.User.create ()) ?name ?__FILE__:file suite =
+    let test_command =
+      let term =
+        let+ () = set_color (module P)
+        and+ cli_config =
+          Config.User.term ~and_exit:false ~record_backtrace:true
+        in
+        let config = Config.User.(cli_config || config) in
+        run ?pos ~config ?name ?__FILE__:file suite
       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 config args library_name tests =
-    let and_exit = Config.User.and_exit config
-    and record_backtrace = Config.User.record_backtrace config in
-    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 ~record_backtrace
-      and+ args = args in
-      let config = Config.User.(cli_config || config) in
-      run_with_args' config library_name args tests
+      (term, Term.info "test")
     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 ~record_backtrace: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 ( >>= ) = M.bind in
-    let choices = [ list_cmd tl; test_cmd config args name tl ] in
-    let and_exit = Config.User.and_exit config 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 config args name tl)
-        choices
+    let list_command =
+      let term =
+        let+ () = set_color (module P) in
+        list_tests ~name suite
+      in
+      (term, Term.info "list")
     in
-    match result with
-    | `Ok unit_m -> unit_m >>= fun () -> exit_or_return (`Ok ())
+    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)
+end
 
-  let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only
-      ?show_errors ?json ?filter ?log_dir ?bail ?record_backtrace ?argv =
-    Config.User.kcreate (run_with_args' ~argv) ?and_exit ?verbose ?compact
-      ?tail_errors ?quick_only ?show_errors ?json ?filter ?log_dir ?bail
-      ?record_backtrace
+module Make_v1 : V1_types.MAKER =
+functor
+  (P : Platform.MAKER)
+  (M : Monad.S)
+  ->
+  struct
+    (**  *)
 
-  let run =
-    Config.User.kcreate (fun config ?argv name tl ->
-        run_with_args' config ~argv name (Term.pure ()) tl)
-end
+    (** 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.V1.Make (P) (M)
+    include C
+    module P = P (M)
+    open Cmdliner_syntax
+
+    let default_cmd config args library_name tests =
+      let and_exit = Config.User.and_exit config
+      and record_backtrace = Config.User.record_backtrace config in
+      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 ~record_backtrace
+        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 ~record_backtrace: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 ( >>= ) = M.bind in
+      let choices = [ list_cmd name tl; test_cmd config args name tl ] in
+      let and_exit = Config.User.and_exit config 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 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 ?record_backtrace ?argv =
+      Config.User.kcreate (run_with_args' ~argv) ?and_exit ?verbose ?compact
+        ?tail_errors ?quick_only ?show_errors ?json ?filter:None ?log_dir ?bail
+        ?record_backtrace
+
+    let run ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors
+        ?json ?filter:_ ?log_dir ?bail ?record_backtrace ?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 ?record_backtrace
+  end
 
 module V1 = struct
   include V1_types
+  module Make = Make_v1
+end
+
+module Unstable = struct
   module Make = Make
 end

src/alcotest-engine/cli_intf.ml

@@ -63,7 +63,10 @@ module type Cli = sig
     module type S = V1_types.S
     module type MAKER = V1_types.MAKER
 
-    module Make (P : Platform.MAKER) (M : Monad.S) :
-      V1_types.S with type return = unit M.t
+    module Make : MAKER
+  end
+
+  module Unstable : sig
+    module Make : Core.Unstable.MAKER
   end
 end