Added a simple version of a polling loop. (#1140)

`dune build -w` keeps running and automatically rebuilds the project
when changes are detected.

Note that on platforms other than Linux, you need to have `fswatch`
installed for watch mode to work.

Signed-off-by: Pavel Senchanka <pavel.senchanka@gmail.com>

bin/main.ml

@@ -57,6 +57,8 @@ type common =
     orig_args             : string list
   ; config                : Config.t
   ; default_target        : string
+  (* For build & runtest only *)
+  ; watch : bool
   }
 
 let prefix_target common s = common.target_prefix ^ s
@@ -75,6 +77,7 @@ let set_common_other c ~targets =
   Clflags.diff_command := c.diff_command;
   Clflags.auto_promote := c.auto_promote;
   Clflags.force := c.force;
+  Clflags.watch := c.watch;
   Clflags.external_lib_deps_hint :=
     List.concat
       [ ["dune"; "external-lib-deps"; "--missing"]
@@ -130,6 +133,39 @@ module Log = struct
     Log.create ~display:common.config.display ()
 end
 
+let watch_command =
+  lazy (
+    let excludes = [ {|\.#|}
+                   ; {|_build|}
+                   ; {|\.hg|}
+                   ; {|\.git|}
+                   ; {|~$|}
+                   ; {|/#[^#]*#$|}
+                   ; {|\.install$|}
+                   ]
+    in
+    let path = Path.to_string_maybe_quoted Path.root in
+    match Bin.which "inotifywait" with
+    | Some inotifywait ->
+      (* On Linux, use inotifywait. *)
+      let excludes = String.concat ~sep:"|" excludes in
+      inotifywait, ["-r"; path; "--exclude"; excludes; "-e"; "close_write"; "-q"]
+    | None ->
+      (* On all other platforms, try to use fswatch. fswatch's event
+         filtering is not reliable (at least on Linux), so don't try to
+         use it, instead act on all events. *)
+      (match Bin.which "fswatch" with
+       | Some fswatch ->
+         let excludes = List.concat_map excludes ~f:(fun x -> ["--exclude"; x]) in
+         fswatch, ["-r"; path; "-1"] @ excludes
+       | None ->
+         die "@{<error>Error@}: fswatch (or inotifywait) was not found. \
+              One of them needs to be installed for watch mode to work.\n"))
+
+let watch_changes () =
+  let watch, args = Lazy.force watch_command in
+  Process.run Strict watch args ~env:Env.initial ~stdout_to:(File Config.dev_null)
+
 module Scheduler = struct
   include Dune.Scheduler
 
@@ -140,6 +176,22 @@ module Scheduler = struct
       fiber
     in
     Scheduler.go ?log ~config:common.config fiber
+
+  let poll ?log ?cache_init ~common ~init ~once ~finally () =
+    let init () =
+      Main.set_concurrency ?log common.config
+      >>= fun () ->
+      init ()
+    in
+    Scheduler.poll
+      ?log
+      ~config:common.config
+      ?cache_init
+      ~init
+      ~once
+      ~finally
+      ~watch:watch_changes
+      ()
 end
 
 type target =
@@ -331,6 +383,12 @@ let common =
          & info ["force"; "f"]
              ~doc:"Force actions associated to aliases to be re-executed even
                    if their dependencies haven't changed.")
+  and watch =
+    Arg.(value
+         & flag
+         & info ["watch"; "w"]
+             ~doc:"Instead of terminating build after completion, wait continuously
+              for file changes.")
   and root,
       only_packages,
       ignore_promoted_rules,
@@ -556,6 +614,7 @@ let common =
   ; config
   ; build_dir
   ; default_target
+  ; watch
   }
 
 let installed_libraries =
@@ -753,6 +812,25 @@ let resolve_targets_exn ~log common setup user_targets =
     | Ok targets ->
       targets)
 
+let run_build_command ~log ~common ~targets =
+  let init () = Fiber.return () in
+  let once () =
+    Main.setup ~log common
+    >>= fun setup ->
+    do_build setup (targets setup)
+  in
+  let finally () =
+    Hooks.End_of_build.run ();
+    Fiber.return ()
+  in
+  if common.watch then begin
+    (* Forcing this lazy here causes the exception raised when watch binary is not found
+       to actually terminate the program, instead of entering an error loop. *)
+    ignore (Lazy.force watch_command);
+    Scheduler.poll ~cache_init:false ~log ~common ~init ~once ~finally ()
+  end
+  else Scheduler.go ~log ~common (once ())
+
 let build_targets =
   let doc = "Build the given targets, or all installable targets if none are given." in
   let man =
@@ -773,10 +851,8 @@ let build_targets =
     in
     set_common common ~targets;
     let log = Log.create common in
-    Scheduler.go ~log ~common
-      (Main.setup ~log common >>= fun setup ->
-       let targets = resolve_targets_exn ~log common setup targets in
-       do_build setup targets)
+    let targets setup = resolve_targets_exn ~log common setup targets in
+    run_build_command ~log ~common ~targets
   in
   (term, Term.info "build" ~doc ~man)
 
@@ -800,16 +876,14 @@ let runtest =
         | dir when dir.[String.length dir - 1] = '/' -> sprintf "@%sruntest" dir
         | dir -> sprintf "@%s/runtest" dir));
     let log = Log.create common in
-    Scheduler.go ~log ~common
-      (Main.setup ~log common >>= fun setup ->
-       let check_path = check_path setup.contexts in
-       let targets =
-         List.map dirs ~f:(fun dir ->
-           let dir = Path.(relative root) (prefix_target common dir) in
-           check_path dir;
-           Alias_rec (Path.relative dir "runtest"))
-       in
-       do_build setup targets)
+    let targets (setup : Main.setup) =
+      let check_path = check_path setup.contexts in
+      List.map dirs ~f:(fun dir ->
+        let dir = Path.(relative root) (prefix_target common dir) in
+        check_path dir;
+        Alias_rec (Path.relative dir "runtest"))
+    in
+    run_build_command ~log ~common ~targets
   in
   (term, Term.info "runtest" ~doc ~man)
 

src/build_system.ml

@@ -612,7 +612,7 @@ let create_file_specs t targets rule ~copy_source =
 let pending_targets = ref Path.Set.empty
 
 let () =
-  at_exit (fun () ->
+  Hooks.End_of_build.always (fun () ->
     let fns = !pending_targets in
     pending_targets := Path.Set.empty;
     Path.Set.iter fns ~f:Path.unlink_no_err)
@@ -1257,7 +1257,7 @@ let create ~contexts ~file_tree ~hook =
     ; hook
     }
   in
-  at_exit (fun () -> finalize t);
+  Hooks.End_of_build.once (fun () -> finalize t);
   t
 
 let eval_request t ~request ~process_target =

src/clflags.ml

@@ -9,3 +9,4 @@ let debug_backtraces = ref false
 let diff_command = ref None
 let auto_promote = ref false
 let force = ref false
+let watch = ref false

src/clflags.mli

@@ -32,3 +32,6 @@ val auto_promote : bool ref
 
 (** Force re-running actions associated to aliases *)
 val force : bool ref
+
+(** Instead of terminating build after completion, watch for changes *)
+val watch : bool ref

src/dir_contents.ml

@@ -684,6 +684,11 @@ end
 
 let cache = Hashtbl.create 32
 
+let clear_cache () =
+  Hashtbl.reset cache
+
+let () = Hooks.End_of_build.always clear_cache
+
 let rec get sctx ~dir =
   match Hashtbl.find cache dir with
   | Some t -> t

src/hooks.ml

@@ -0,0 +1,20 @@
+open Stdune
+
+module End_of_build = struct
+  let persistent_hooks = ref []
+
+  let one_off_hooks = ref []
+
+  let always hook =
+    persistent_hooks := hook :: !persistent_hooks
+
+  let once hook =
+    one_off_hooks := hook :: !one_off_hooks
+
+  let run () =
+    List.iter !one_off_hooks ~f:(fun f -> f ());
+    List.iter !persistent_hooks ~f:(fun f -> f ());
+    one_off_hooks := []
+end
+
+let () = at_exit End_of_build.run

src/hooks.mli

@@ -0,0 +1,21 @@
+(** This module deals with management of hooks that run
+    after specific events (e.g. end of build). *)
+
+module End_of_build : sig
+  (** Register a hook called at the end of every build.
+
+      For watch mode, this means that once registered, the hook
+      will be called after every iteration. *)
+  val always : (unit -> unit) -> unit
+
+  (** Register a hook called at the end of current build only.
+
+      For watch mode, this means that after current iteration
+      is over, the hook will be called and deregistered
+      automatically. *)
+  val once : (unit -> unit) -> unit
+
+
+  (** Signalize end of build and run all registered hooks. *)
+  val run : unit -> unit
+end

src/main.ml

@@ -84,7 +84,10 @@ let setup ?(log=Log.no_log)
   let rule_done  = ref 0 in
   let rule_total = ref 0 in
   let gen_status_line () =
-    Some (sprintf "Done: %u/%u" !rule_done !rule_total)
+    { Scheduler.
+      message = Some (sprintf "Done: %u/%u" !rule_done !rule_total)
+    ; show_jobs = true
+    }
   in
   let hook (hook : Build_system.hook) =
     match hook with

src/promotion.ml

@@ -19,12 +19,17 @@ module File = struct
   let register t = db := t :: !db
 
   let promote { src; dst } =
-    Format.eprintf "Promoting %s to %s.@."
+    Errors.print_to_console (Format.sprintf "Promoting %s to %s.@."
       (Path.to_string_maybe_quoted src)
-      (Path.to_string_maybe_quoted dst);
+      (Path.to_string_maybe_quoted dst));
     Io.copy_file ~src ~dst ()
 end
 
+let clear_cache () =
+  File.db := []
+
+let () = Hooks.End_of_build.always clear_cache
+
 module P = Utils.Persistent(struct
     type t = File.t list
     let name = "TO-PROMOTE"
@@ -49,6 +54,8 @@ let group_by_targets db =
   (* Sort the list of possible sources for deterministic behavior *)
   |> Path.Map.map ~f:(List.sort ~compare:Path.compare)
 
+let were_files_promoted = ref false
+
 type files_to_promote =
   | All
   | These of Path.t list * (Path.t -> unit)
@@ -79,6 +86,7 @@ let do_promote db files_to_promote =
       List.iter dirs_to_clear_from_cache ~f:(fun dir ->
         Utils.Cached_digest.remove (Path.append dir dst));
       File.promote { src; dst };
+      were_files_promoted := true;
       List.iter others ~f:(fun path ->
         Format.eprintf " -> ignored %s.@."
           (Path.to_string_maybe_quoted path))
@@ -106,6 +114,7 @@ let do_promote db files_to_promote =
       List.map srcs ~f:(fun src -> { File.src; dst }))
 
 let finalize () =
+  were_files_promoted := false;
   let db =
     if !Clflags.auto_promote then
       do_promote !File.db All
@@ -114,6 +123,9 @@ let finalize () =
   in
   dump_db db
 
+let were_files_promoted () =
+  !were_files_promoted
+
 let promote_files_registered_in_last_run files_to_promote =
   let db = load_db () in
   let db = do_promote db files_to_promote in

src/promotion.mli

@@ -14,6 +14,9 @@ end
     dump the list of registered files to [_build/.to-promote]. *)
 val finalize : unit -> unit
 
+(** Returns true if any files were promoted the last time [finalize] ran. *)
+val were_files_promoted : unit -> bool
+
 (** Describe what files should be promoted. The second argument of
     [These] is a function that is called on files that cannot be
     promoted. *)

src/report_error.ml

@@ -118,6 +118,11 @@ let report_with_backtrace exn =
 
 let reported = ref String.Set.empty
 
+let clear_cache () =
+  reported := String.Set.empty
+
+let () = Hooks.End_of_build.always clear_cache
+
 let report exn =
   let exn, dependency_path = Dep_path.unwrap_exn exn in
   match exn with

src/scheduler.ml

@@ -2,6 +2,11 @@ open! Stdune
 open Import
 open Fiber.O
 
+type status_line_config =
+  { message   : string option
+  ; show_jobs : bool
+  }
+
 type running_job =
   { pid  : int
   ; ivar : Unix.process_status Fiber.Ivar.t
@@ -66,7 +71,7 @@ type t =
   ; mutable concurrency       : int
   ; waiting_for_available_job : t Fiber.Ivar.t Queue.t
   ; mutable status_line       : string
-  ; mutable gen_status_line   : unit -> string option
+  ; mutable gen_status_line   : unit -> status_line_config
   }
 
 let log t = t.log
@@ -136,13 +141,18 @@ let rec go_rec t =
   end else begin
     if t.display = Progress then begin
       match t.gen_status_line () with
-      | None ->
+      | { message = None; _ } ->
         if t.status_line <> "" then begin
           hide_status_line t.status_line;
           flush stderr
         end
-      | Some status_line ->
-        let status_line = sprintf "%s (jobs: %u)" status_line count in
+      | { message = Some status_line; show_jobs } ->
+        let status_line =
+          if show_jobs then
+            sprintf "%s (jobs: %u)" status_line count
+          else
+            status_line
+        in
         hide_status_line t.status_line;
         show_status_line   status_line;
         flush stderr;
@@ -156,8 +166,8 @@ let rec go_rec t =
     go_rec t
   end
 
-let go ?(log=Log.no_log) ?(config=Config.default)
-      ?(gen_status_line=fun () -> None) fiber =
+let prepare ?(log=Log.no_log) ?(config=Config.default)
+      ?(gen_status_line=fun () -> { message = None; show_jobs = false }) () =
   Log.infof log "Workspace root: %s"
     (Path.to_absolute_filename Path.root |> String.maybe_quoted);
   let cwd = Sys.getcwd () in
@@ -190,18 +200,102 @@ let go ?(log=Log.no_log) ?(config=Config.default)
     { log
     ; gen_status_line
     ; original_cwd = cwd
-    ; display      = config.display
+    ; display      = config.Config.display
     ; concurrency  = (match config.concurrency with Auto -> 1 | Fixed n -> n)
     ; status_line  = ""
     ; waiting_for_available_job = Queue.create ()
     }
   in
   Errors.printer := print t;
+  t
+
+let run t fiber =
   let fiber =
     Fiber.Var.set t_var t
-      (Fiber.with_error_handler (fun () -> fiber) ~on_error:Report_error.report)
+      (Fiber.with_error_handler fiber ~on_error:Report_error.report)
   in
   Fiber.run
     (Fiber.fork_and_join_unit
        (fun () -> go_rec t)
        (fun () -> fiber))
+
+let go ?log ?config ?gen_status_line fiber =
+  let t = prepare ?log ?config ?gen_status_line () in
+  run t (fun () -> fiber)
+
+(** Fiber loop looks like this (if cache_init is true):
+              /------------------\
+              v                  |
+    init --> once --> finally  --/
+
+    The result of [~init] gets passed in every call to [~once] and [~finally].
+    If cache_init is false, every iteration reexecutes init instead of
+    saving it.
+
+    [~watch] should return after the first change to any of the project files.
+*)
+let poll ?log ?config ?(cache_init=true) ~init ~once ~finally ~watch () =
+  let t = prepare ?log ?config () in
+  let wait_success () =
+    let old_generator = t.gen_status_line in
+    set_status_line_generator
+      (fun () ->
+         { message = Some "Success.\nWaiting for filesystem changes..."
+         ; show_jobs = false
+         })
+    >>= fun () ->
+    watch ()
+    >>= fun _ ->
+    set_status_line_generator old_generator
+  in
+  let wait_failure () =
+    let old_generator = t.gen_status_line in
+    set_status_line_generator
+      (fun () ->
+         { message = Some "Had errors.\nWaiting for filesystem changes..."
+         ; show_jobs = false
+         })
+    >>= fun () ->
+    (if Promotion.were_files_promoted () then
+       Fiber.return ()
+     else
+       watch ())
+    >>= fun _ ->
+    set_status_line_generator old_generator
+  in
+  let rec main_loop () =
+    (if cache_init then
+       Fiber.return ()
+     else
+       init ())
+    >>= fun _ ->
+    once ()
+    >>= fun _ ->
+    finally ()
+    >>= fun _ ->
+    wait_success ()
+    >>= fun _ ->
+    main_loop ()
+  in
+  let continue_on_error () =
+    finally ()
+    >>= fun _ ->
+    wait_failure ()
+    >>= fun _ ->
+    main_loop ()
+  in
+  let main () =
+    (if cache_init then
+       init ()
+     else
+       Fiber.return ())
+    >>= fun _ ->
+    main_loop ()
+  in
+  let rec loop f =
+    try
+      run t f
+    with Fiber.Never ->
+      loop continue_on_error
+  in
+  loop main

src/scheduler.mli

@@ -2,21 +2,47 @@
 
 open! Stdune
 
+type status_line_config =
+  { message   : string option
+  ; show_jobs : bool
+  }
+
 (** [go ?log ?config ?gen_status_line fiber] runs the following fiber until it
     terminates. [gen_status_line] is used to print a status line when [config.display =
     Progress]. *)
 val go
   :  ?log:Log.t
   -> ?config:Config.t
-  -> ?gen_status_line:(unit -> string option)
+  -> ?gen_status_line:(unit -> status_line_config)
   -> 'a Fiber.t
   -> 'a
 
+(** Runs a fiber loop that looks like this (if cache_init is true, as default):
+              /------------------\
+              v                  |
+    init --> once --> finally  --/
+
+    If cache_init is false, every iteration reexecutes init instead of
+    saving it.
+
+    [~watch] should return after the first change to any of the project files.
+*)
+val poll
+  :  ?log:Log.t
+  -> ?config:Config.t
+  -> ?cache_init:bool
+  -> init:(unit -> unit Fiber.t)
+  -> once:(unit -> unit Fiber.t)
+  -> finally:(unit -> unit Fiber.t)
+  -> watch:(unit -> unit Fiber.t)
+  -> unit
+  -> 'a
+
 (** Wait for the following process to terminate *)
 val wait_for_process : int -> Unix.process_status Fiber.t
 
 (** Set the status line generator for the current scheduler *)
-val set_status_line_generator : (unit -> string option) -> unit Fiber.t
+val set_status_line_generator : (unit -> status_line_config) -> unit Fiber.t
 
 val set_concurrency : int -> unit Fiber.t
 

src/stdune/hashtbl.ml

@@ -68,6 +68,7 @@ let replace = replace
 let length = length
 let remove = remove
 let mem = mem
+let reset = reset
 
 let find = find_opt
 

src/stdune/hashtbl.mli

@@ -8,6 +8,8 @@ val hash : 'a -> int
 
 val create : ?random:bool -> int -> ('a, 'b) t
 
+val reset : ('a, 'b) t -> unit
+
 val remove : ('a, _) t -> 'a -> unit
 
 val length : (_, _) t -> int