From 8f2a4c07419347503a8bcb1881e1b1308711a8cf Mon Sep 17 00:00:00 2001 From: Pavel Senchanka Date: Wed, 5 Sep 2018 05:53:21 -0400 Subject: [PATCH] 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 --- bin/main.ml | 102 ++++++++++++++++++++++++++++++++------ src/build_system.ml | 4 +- src/clflags.ml | 1 + src/clflags.mli | 3 ++ src/dir_contents.ml | 5 ++ src/hooks.ml | 20 ++++++++ src/hooks.mli | 21 ++++++++ src/main.ml | 5 +- src/promotion.ml | 16 +++++- src/promotion.mli | 3 ++ src/report_error.ml | 5 ++ src/scheduler.ml | 110 ++++++++++++++++++++++++++++++++++++++--- src/scheduler.mli | 30 ++++++++++- src/stdune/hashtbl.ml | 1 + src/stdune/hashtbl.mli | 2 + 15 files changed, 299 insertions(+), 29 deletions(-) create mode 100644 src/hooks.ml create mode 100644 src/hooks.mli diff --git a/bin/main.ml b/bin/main.ml index 686ad492..094b7f41 100644 --- a/bin/main.ml +++ b/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@}: 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) diff --git a/src/build_system.ml b/src/build_system.ml index 8400b9d5..0a4c6153 100644 --- a/src/build_system.ml +++ b/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 = diff --git a/src/clflags.ml b/src/clflags.ml index 375bceb6..3de60589 100644 --- a/src/clflags.ml +++ b/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 diff --git a/src/clflags.mli b/src/clflags.mli index ba160617..467bc3f9 100644 --- a/src/clflags.mli +++ b/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 diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 77645dbf..80544e4c 100644 --- a/src/dir_contents.ml +++ b/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 diff --git a/src/hooks.ml b/src/hooks.ml new file mode 100644 index 00000000..52e53c79 --- /dev/null +++ b/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 diff --git a/src/hooks.mli b/src/hooks.mli new file mode 100644 index 00000000..6b40fe06 --- /dev/null +++ b/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 diff --git a/src/main.ml b/src/main.ml index 30f71d93..e460963f 100644 --- a/src/main.ml +++ b/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 diff --git a/src/promotion.ml b/src/promotion.ml index 4a7ff880..803f2fd1 100644 --- a/src/promotion.ml +++ b/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 diff --git a/src/promotion.mli b/src/promotion.mli index 0a1025e7..28d6d538 100644 --- a/src/promotion.mli +++ b/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. *) diff --git a/src/report_error.ml b/src/report_error.ml index d05e9c1f..627a5acf 100644 --- a/src/report_error.ml +++ b/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 diff --git a/src/scheduler.ml b/src/scheduler.ml index 747f69be..aa2ec2cd 100644 --- a/src/scheduler.ml +++ b/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 diff --git a/src/scheduler.mli b/src/scheduler.mli index 615e45ba..b0811511 100644 --- a/src/scheduler.mli +++ b/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 diff --git a/src/stdune/hashtbl.ml b/src/stdune/hashtbl.ml index 5383fee4..226399d9 100644 --- a/src/stdune/hashtbl.ml +++ b/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 diff --git a/src/stdune/hashtbl.mli b/src/stdune/hashtbl.mli index 001492be..1fa5fe36 100644 --- a/src/stdune/hashtbl.mli +++ b/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