Add option to force running tests (#320)

Option to force running tests

The mechanism allows for forcing any alias, but only forcing tests is exposed to the user. Aliases are forced by deleting all the alias files that belong to a particular alias. The option for forcing tests is called --force.

bin/main.ml

@@ -62,9 +62,10 @@ let execve =
 module Main = struct
   include Jbuilder.Main
 
-  let setup ~log ?filter_out_optional_stanzas_with_missing_deps common =
+  let setup ~log ?unlink_aliases ?filter_out_optional_stanzas_with_missing_deps common =
     setup
       ~log
+      ?unlink_aliases
       ?workspace_file:common.workspace_file
       ?only_packages:common.only_packages
       ?filter_out_optional_stanzas_with_missing_deps ()
@@ -468,7 +469,8 @@ let runtest =
     ]
   in
   let name_ = Arg.info [] ~docv:"DIR" in
-  let go common dirs =
+  let go common force dirs =
+    let unlink_aliases = if force then Some ["runtest"] else None in
     set_common common
       ~targets:(List.map dirs ~f:(function
         | "" | "." -> "@runtest"
@@ -476,7 +478,7 @@ let runtest =
         | dir -> sprintf "@%s/runtest" dir));
     let log = Log.create () in
     Future.Scheduler.go ~log
-      (Main.setup ~log common >>= fun setup ->
+      (Main.setup ?unlink_aliases ~log common >>= fun setup ->
        let targets =
          List.map dirs ~f:(fun dir ->
            let dir = Path.(relative root) (prefix_target common dir) in
@@ -485,6 +487,7 @@ let runtest =
        do_build setup targets) in
   ( Term.(const go
           $ common
+          $ Arg.(value & flag & info ["force"; "f"])
           $ Arg.(value & pos_all string ["."] name_))
   , Term.info "runtest" ~doc ~man)
 

src/alias.ml

@@ -138,6 +138,18 @@ module Store = struct
     Format.fprintf fmt "Store.t@ @[@<2>(%a)@]" pp_bindings bindings
 
   let create () = Hashtbl.create 1024
+
+  let unlink (store : t) = function
+    | [] -> ()
+    | alias_basenames ->
+      store
+      |> Hashtbl.fold ~init:Path.Set.empty ~f:(fun ~key:_ ~data:entry acc ->
+        if List.mem (name entry.alias) ~set:alias_basenames then (
+          Path.Set.union acc (Path.Set.add entry.alias.file entry.deps)
+        ) else (
+          acc
+        ))
+      |> Path.Set.iter ~f:Path.unlink_no_err
 end
 
 let add_deps store t deps =

src/alias.mli

@@ -62,6 +62,8 @@ module Store : sig
   val pp : t Fmt.t
 
   val create : unit -> t
+
+  val unlink : t -> string list -> unit
 end
 
 val add_deps : Store.t -> t -> Path.t list -> unit

src/gen_rules.ml

@@ -1104,7 +1104,7 @@ Add it to your jbuild file to remove this warning.
 end
 
 let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true)
-      ?only_packages conf =
+      ?only_packages ?(unlink_aliases=[]) conf =
   let open Future in
   let { Jbuild_load. file_tree; jbuilds; packages } = conf in
   let aliases = Alias.Store.create () in
@@ -1152,5 +1152,6 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true)
   |> Future.all
   >>| fun l ->
   let rules, context_names_and_stanzas = List.split l in
+  Alias.Store.unlink aliases unlink_aliases;
   (Alias.rules aliases @ List.concat rules,
    String_map.of_alist_exn context_names_and_stanzas)

src/gen_rules.mli

@@ -5,6 +5,7 @@ val gen
   :  contexts:Context.t list
   -> ?filter_out_optional_stanzas_with_missing_deps:bool (* default: true *)
   -> ?only_packages:String_set.t
+  -> ?unlink_aliases:string list
   -> Jbuild_load.conf
   -> (Build_interpret.Rule.t list *
      (* Evaluated jbuilds per context names *)

src/import.ml

@@ -553,4 +553,11 @@ end
 
 module Fmt = struct
   type 'a t = Format.formatter -> 'a -> unit
+
+  let kstrf f fmt =
+    let buf = Buffer.create 17 in
+    let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in
+    Format.kfprintf f (Format.formatter_of_buffer buf) fmt
+
+  let failwith fmt = kstrf failwith fmt
 end

src/main.ml

@@ -14,7 +14,8 @@ let package_install_file { packages; _ } pkg =
   | None -> Error ()
   | Some p -> Ok (Path.relative p.path (p.name ^ ".install"))
 
-let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps
+let setup ?(log=Log.no_log) ?unlink_aliases
+      ?filter_out_optional_stanzas_with_missing_deps
       ?workspace ?(workspace_file="jbuild-workspace")
       ?(use_findlib=true)
       ?only_packages
@@ -47,6 +48,7 @@ let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps
   List.iter contexts ~f:(fun ctx ->
     Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp (Context.sexp_of_t ctx));
   Gen_rules.gen conf ~contexts
+    ?unlink_aliases
     ?only_packages
     ?filter_out_optional_stanzas_with_missing_deps
   >>= fun (rules, stanzas) ->

src/main.mli

@@ -17,6 +17,7 @@ val package_install_file : setup -> string -> (Path.t, unit) result
     it. *)
 val setup
   :  ?log:Log.t
+  -> ?unlink_aliases:string list
   -> ?filter_out_optional_stanzas_with_missing_deps:bool
   -> ?workspace:Workspace.t
   -> ?workspace_file:string

test/blackbox-tests/jbuild

@@ -78,3 +78,10 @@
   (action
    (chdir test-cases/aliases
     (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+
+(alias
+ ((name runtest)
+  (deps ((files_recursively_in test-cases/force-test)))
+  (action
+   (chdir test-cases/force-test
+    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))

test/blackbox-tests/test-cases/force-test/f.ml

@@ -0,0 +1,2 @@
+
+let () = print_endline "Foo Bar"

test/blackbox-tests/test-cases/force-test/jbuild

@@ -0,0 +1,9 @@
+(jbuild_version 1)
+
+(executable
+ ((name f)))
+
+(alias
+ ((name runtest)
+  (deps (f.exe))
+  (action (run ${<}))))

test/blackbox-tests/test-cases/force-test/run.t

@@ -0,0 +1,12 @@
+  $ $JBUILDER clean -j1 --root .
+  $ $JBUILDER runtest -j1 --root .
+      ocamldep f.depends.ocamldep-output
+        ocamlc f.{cmi,cmo,cmt}
+      ocamlopt f.{cmx,o}
+      ocamlopt f.exe
+             f alias runtest
+  Foo Bar
+  $ $JBUILDER runtest -j1 --root .
+  $ $JBUILDER runtest --force -j1 --root .
+             f alias runtest
+  Foo Bar