Initial config-sensitive filter

Author: craigfe

src/alcotest-engine/alcotest_engine.ml

@@ -10,6 +10,7 @@ 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

src/alcotest-engine/alcotest_engine.mli

@@ -52,6 +52,7 @@ module Unstable : sig
   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

src/alcotest-engine/config.ml

@@ -205,7 +205,7 @@ module Key = struct
     module V2 = struct
       type t = filter_v2
 
-      let of_v1 ~quick_only position_filter tags =
+      let of_v1 ~quick_only position_filter _ tags =
         let speed_level =
           match Tag.Set.find Tag.Speed_level.tag tags with
           | Some `Slow -> if quick_only then `Skip else `Run
@@ -223,7 +223,24 @@ module Key = struct
 
     type t = [ `V1 of V1.t | `V2 of V2.t ]
 
-    let default = Tag.Filter.default
+    let default =
+      (* TODO: duplicated *)
+      let only_if _ s =
+        match Tag.Set.find Tag.Predicate.tag s with
+        | Some p -> p ()
+        | None -> `Run
+      in
+
+      let quick_only_config c s =
+        match Tag.Set.find Tag.Speed_level.tag s with
+        | Some `Slow when c#quick_only -> `Skip
+        | _ -> `Run
+      in
+
+      let ( ++ ) f g a b =
+        match (f a b, g a b) with `Run, `Run -> `Run | _, _ -> `Skip
+      in
+      only_if ++ quick_only_config
   end
 end
 
@@ -313,8 +330,8 @@ let apply_defaults ~default_log_dir : User.t -> t =
        verbose;
        compact;
        tail_errors;
-       quick_only;
        show_errors;
+       quick_only;
        json;
        filter;
        log_dir;

src/alcotest-engine/config_intf.ml

@@ -1,10 +1,14 @@
 module Types = struct
   type bound = [ `Unlimited | `Limit of int ]
-  type filter_v1 = name:string -> index:int -> [ `Run | `Skip ]
-  type filter_v2 = Tag.Filter.t
-  type filter = [ `V1 of filter_v1 | `V2 of filter_v2 ]
+  type filter_result = [ `Run | `Skip ]
 
-  type t =
+  type filter_v1 = name:string -> index:int -> filter_result
+
+  and filter_v2 = t -> Tag.Set.t -> filter_result
+
+  and filter = [ `V1 of filter_v1 | `V2 of filter_v2 ]
+
+  and t =
     < and_exit : bool
     ; verbose : bool
     ; compact : bool

src/alcotest-engine/core.ml

@@ -198,13 +198,10 @@ module Make (P : Platform.MAKER) (M : Monad.S) = struct
     let+ (result : Run_result.t) = with_captured_logs t index test args in
     (* 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
+      if Run_result.is_failure result then (
+        t.errors <- Fmt.const (pp_error t) result :: t.errors;
+        true)
+      else false
     in
     (* Show any remaining test output before the event *)
     Fmt.(flush stdout ());
@@ -238,7 +235,8 @@ module Make (P : Platform.MAKER) (M : Monad.S) = struct
       ();
     let start_time = P.time () in
     let+ results =
-      Suite.foldi_until t.suite ~filter:t.config#filter
+      Suite.foldi_until t.suite
+        ~filter:(Filter.apply t.config#filter t.config)
         ~init:{ tests_so_far = 0; first_error = None; failures = 0 }
         ~finish:(fun x -> x)
         ~group:(fun _ctx acc _ ->
@@ -286,7 +284,9 @@ module Make (P : Platform.MAKER) (M : Monad.S) = struct
     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:()
+      Suite.foldi_until suite
+        ~filter:(Filter.apply config#filter config)
+        ~init:()
         ~finish:(fun () -> false)
         ~test:
           (fun _ () -> function

src/alcotest-engine/filter.ml

@@ -0,0 +1,17 @@
+type t = Config.filter_v2
+
+let v f _ = f
+
+let ( ++ ) f g a b =
+  match (f a b, g a b) with `Run, `Run -> `Run | _, _ -> `Skip
+
+let only_if _ s =
+  match Tag.Set.find Tag.Predicate.tag s with Some p -> p () | None -> `Run
+
+let quick_only_config c s =
+  match Tag.Set.find Tag.Speed_level.tag s with
+  | Some `Slow when c#quick_only -> `Skip
+  | _ -> `Run
+
+let default = only_if ++ quick_only_config
+let apply f = f

src/alcotest-engine/filter.mli

@@ -0,0 +1,15 @@
+type t = Config.filter_v2
+
+val v : (Tag.Set.t -> [ `Run | `Skip ]) -> t
+
+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
+
+(** Internal: *)
+
+val apply : t -> Config.t -> Tag.Set.t -> [ `Run | `Skip ]
+val quick_only_config : t
+val only_if : t

src/alcotest-engine/model.mli

@@ -31,6 +31,8 @@ end
 
 module Suite (M : Monad.S) : sig
   type 'a test
+  type filter_result := [ `Run | `Skip ]
+  type filter := Tag.Set.t -> filter_result
 
   val test :
     name:string ->
@@ -49,12 +51,9 @@ module Suite (M : Monad.S) : sig
   type 'a t
 
   val foldi_until :
-    filter:Tag.Filter.t ->
+    filter:filter ->
     ?group:
-      (Index.t ->
-      'acc ->
-      [ `Run | `Skip ] ->
-      ('acc, 'final) continue_or_stop M.t) ->
+      (Index.t -> 'acc -> filter_result -> ('acc, 'final) continue_or_stop M.t) ->
     ?test:
       (Index.t ->
       'acc ->
@@ -68,8 +67,8 @@ module Suite (M : Monad.S) : sig
       [filter] predicate defined over node {!Tag}s. *)
 
   val fold :
-    filter:Tag.Filter.t ->
-    group:('acc -> [ `Run | `Skip ] -> 'acc) ->
+    filter:filter ->
+    group:('acc -> filter_result -> 'acc) ->
     test:('acc -> [ `Run of 'a -> unit M.t | `Skip ] -> 'acc) ->
     init:'acc ->
     'a t ->

src/alcotest-engine/tag.ml

@@ -97,9 +97,6 @@ module Speed_level = struct
 
   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
@@ -108,17 +105,8 @@ module Predicate = struct
   let tag =
     Key.create ~name:"Predicate" ~pp_data:(fun ppf _ ->
         Fmt.pf ppf "Predicate <...>")
-
-  let only_if s = match Set.find tag s with Some p -> p () | None -> `Run
 end
 
 module Position = struct
   let tag = Key.create ~name:"index" ~pp_data:Fmt.(using snd int)
 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 = Predicate.only_if (* TODO: be sensitive to `quick_only` *)
-end

src/alcotest-engine/tag.mli

@@ -31,24 +31,13 @@ module Set : sig
 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 Key.t
   val quick : tag
   val slow : tag
-  val without_slow : Filter.t
 end
 with type tag := t
 
@@ -60,5 +49,4 @@ module Predicate : sig
   type t = unit -> [ `Run | `Skip ]
 
   val tag : t Key.t
-  val only_if : Filter.t
 end

src/alcotest/alcotest.mli

@@ -84,7 +84,7 @@ module Unstable : sig
       ?quick_only:bool ->
       ?show_errors:bool ->
       ?json:bool ->
-      ?filter:Tag.Filter.t ->
+      ?filter:Filter.t ->
       ?bail:bool ->
       ?log_dir:string ->
       unit ->

test/e2e/alcotest/passing/quick_only.expected

@@ -2,9 +2,9 @@ Testing `test/e2e/alcotest/passing/quick_only.ml'.
 This run has ID `<uuid>'.
 
   [PASS]    test-a › Quick
-  [PASS]    test-a › Slow
-  [PASS]    test-b › Slow
+  [SKIP]    test-a › Slow
+  [SKIP]    test-b › Slow
   [PASS]    test-b › Quick
 
 Full test results in `<build-context>/_build/_tests/<test-dir>'.
-Test Successful in <test-duration>s. 4 tests run.
+Test Successful in <test-duration>s. 2 tests run.