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>
This commit is contained in:
parent
22fe0696ff
commit
8f2a4c0741
102
bin/main.ml
102
bin/main.ml
|
@ -57,6 +57,8 @@ type common =
|
||||||
orig_args : string list
|
orig_args : string list
|
||||||
; config : Config.t
|
; config : Config.t
|
||||||
; default_target : string
|
; default_target : string
|
||||||
|
(* For build & runtest only *)
|
||||||
|
; watch : bool
|
||||||
}
|
}
|
||||||
|
|
||||||
let prefix_target common s = common.target_prefix ^ s
|
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.diff_command := c.diff_command;
|
||||||
Clflags.auto_promote := c.auto_promote;
|
Clflags.auto_promote := c.auto_promote;
|
||||||
Clflags.force := c.force;
|
Clflags.force := c.force;
|
||||||
|
Clflags.watch := c.watch;
|
||||||
Clflags.external_lib_deps_hint :=
|
Clflags.external_lib_deps_hint :=
|
||||||
List.concat
|
List.concat
|
||||||
[ ["dune"; "external-lib-deps"; "--missing"]
|
[ ["dune"; "external-lib-deps"; "--missing"]
|
||||||
|
@ -130,6 +133,39 @@ module Log = struct
|
||||||
Log.create ~display:common.config.display ()
|
Log.create ~display:common.config.display ()
|
||||||
end
|
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
|
module Scheduler = struct
|
||||||
include Dune.Scheduler
|
include Dune.Scheduler
|
||||||
|
|
||||||
|
@ -140,6 +176,22 @@ module Scheduler = struct
|
||||||
fiber
|
fiber
|
||||||
in
|
in
|
||||||
Scheduler.go ?log ~config:common.config fiber
|
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
|
end
|
||||||
|
|
||||||
type target =
|
type target =
|
||||||
|
@ -331,6 +383,12 @@ let common =
|
||||||
& info ["force"; "f"]
|
& info ["force"; "f"]
|
||||||
~doc:"Force actions associated to aliases to be re-executed even
|
~doc:"Force actions associated to aliases to be re-executed even
|
||||||
if their dependencies haven't changed.")
|
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,
|
and root,
|
||||||
only_packages,
|
only_packages,
|
||||||
ignore_promoted_rules,
|
ignore_promoted_rules,
|
||||||
|
@ -556,6 +614,7 @@ let common =
|
||||||
; config
|
; config
|
||||||
; build_dir
|
; build_dir
|
||||||
; default_target
|
; default_target
|
||||||
|
; watch
|
||||||
}
|
}
|
||||||
|
|
||||||
let installed_libraries =
|
let installed_libraries =
|
||||||
|
@ -753,6 +812,25 @@ let resolve_targets_exn ~log common setup user_targets =
|
||||||
| Ok targets ->
|
| Ok targets ->
|
||||||
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 build_targets =
|
||||||
let doc = "Build the given targets, or all installable targets if none are given." in
|
let doc = "Build the given targets, or all installable targets if none are given." in
|
||||||
let man =
|
let man =
|
||||||
|
@ -773,10 +851,8 @@ let build_targets =
|
||||||
in
|
in
|
||||||
set_common common ~targets;
|
set_common common ~targets;
|
||||||
let log = Log.create common in
|
let log = Log.create common in
|
||||||
Scheduler.go ~log ~common
|
let targets setup = resolve_targets_exn ~log common setup targets in
|
||||||
(Main.setup ~log common >>= fun setup ->
|
run_build_command ~log ~common ~targets
|
||||||
let targets = resolve_targets_exn ~log common setup targets in
|
|
||||||
do_build setup targets)
|
|
||||||
in
|
in
|
||||||
(term, Term.info "build" ~doc ~man)
|
(term, Term.info "build" ~doc ~man)
|
||||||
|
|
||||||
|
@ -800,16 +876,14 @@ let runtest =
|
||||||
| dir when dir.[String.length dir - 1] = '/' -> sprintf "@%sruntest" dir
|
| dir when dir.[String.length dir - 1] = '/' -> sprintf "@%sruntest" dir
|
||||||
| dir -> sprintf "@%s/runtest" dir));
|
| dir -> sprintf "@%s/runtest" dir));
|
||||||
let log = Log.create common in
|
let log = Log.create common in
|
||||||
Scheduler.go ~log ~common
|
let targets (setup : Main.setup) =
|
||||||
(Main.setup ~log common >>= fun setup ->
|
let check_path = check_path setup.contexts in
|
||||||
let check_path = check_path setup.contexts in
|
List.map dirs ~f:(fun dir ->
|
||||||
let targets =
|
let dir = Path.(relative root) (prefix_target common dir) in
|
||||||
List.map dirs ~f:(fun dir ->
|
check_path dir;
|
||||||
let dir = Path.(relative root) (prefix_target common dir) in
|
Alias_rec (Path.relative dir "runtest"))
|
||||||
check_path dir;
|
in
|
||||||
Alias_rec (Path.relative dir "runtest"))
|
run_build_command ~log ~common ~targets
|
||||||
in
|
|
||||||
do_build setup targets)
|
|
||||||
in
|
in
|
||||||
(term, Term.info "runtest" ~doc ~man)
|
(term, Term.info "runtest" ~doc ~man)
|
||||||
|
|
||||||
|
|
|
@ -612,7 +612,7 @@ let create_file_specs t targets rule ~copy_source =
|
||||||
let pending_targets = ref Path.Set.empty
|
let pending_targets = ref Path.Set.empty
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
at_exit (fun () ->
|
Hooks.End_of_build.always (fun () ->
|
||||||
let fns = !pending_targets in
|
let fns = !pending_targets in
|
||||||
pending_targets := Path.Set.empty;
|
pending_targets := Path.Set.empty;
|
||||||
Path.Set.iter fns ~f:Path.unlink_no_err)
|
Path.Set.iter fns ~f:Path.unlink_no_err)
|
||||||
|
@ -1257,7 +1257,7 @@ let create ~contexts ~file_tree ~hook =
|
||||||
; hook
|
; hook
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
at_exit (fun () -> finalize t);
|
Hooks.End_of_build.once (fun () -> finalize t);
|
||||||
t
|
t
|
||||||
|
|
||||||
let eval_request t ~request ~process_target =
|
let eval_request t ~request ~process_target =
|
||||||
|
|
|
@ -9,3 +9,4 @@ let debug_backtraces = ref false
|
||||||
let diff_command = ref None
|
let diff_command = ref None
|
||||||
let auto_promote = ref false
|
let auto_promote = ref false
|
||||||
let force = ref false
|
let force = ref false
|
||||||
|
let watch = ref false
|
||||||
|
|
|
@ -32,3 +32,6 @@ val auto_promote : bool ref
|
||||||
|
|
||||||
(** Force re-running actions associated to aliases *)
|
(** Force re-running actions associated to aliases *)
|
||||||
val force : bool ref
|
val force : bool ref
|
||||||
|
|
||||||
|
(** Instead of terminating build after completion, watch for changes *)
|
||||||
|
val watch : bool ref
|
||||||
|
|
|
@ -684,6 +684,11 @@ end
|
||||||
|
|
||||||
let cache = Hashtbl.create 32
|
let cache = Hashtbl.create 32
|
||||||
|
|
||||||
|
let clear_cache () =
|
||||||
|
Hashtbl.reset cache
|
||||||
|
|
||||||
|
let () = Hooks.End_of_build.always clear_cache
|
||||||
|
|
||||||
let rec get sctx ~dir =
|
let rec get sctx ~dir =
|
||||||
match Hashtbl.find cache dir with
|
match Hashtbl.find cache dir with
|
||||||
| Some t -> t
|
| Some t -> t
|
||||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -84,7 +84,10 @@ let setup ?(log=Log.no_log)
|
||||||
let rule_done = ref 0 in
|
let rule_done = ref 0 in
|
||||||
let rule_total = ref 0 in
|
let rule_total = ref 0 in
|
||||||
let gen_status_line () =
|
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
|
in
|
||||||
let hook (hook : Build_system.hook) =
|
let hook (hook : Build_system.hook) =
|
||||||
match hook with
|
match hook with
|
||||||
|
|
|
@ -19,12 +19,17 @@ module File = struct
|
||||||
let register t = db := t :: !db
|
let register t = db := t :: !db
|
||||||
|
|
||||||
let promote { src; dst } =
|
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 src)
|
||||||
(Path.to_string_maybe_quoted dst);
|
(Path.to_string_maybe_quoted dst));
|
||||||
Io.copy_file ~src ~dst ()
|
Io.copy_file ~src ~dst ()
|
||||||
end
|
end
|
||||||
|
|
||||||
|
let clear_cache () =
|
||||||
|
File.db := []
|
||||||
|
|
||||||
|
let () = Hooks.End_of_build.always clear_cache
|
||||||
|
|
||||||
module P = Utils.Persistent(struct
|
module P = Utils.Persistent(struct
|
||||||
type t = File.t list
|
type t = File.t list
|
||||||
let name = "TO-PROMOTE"
|
let name = "TO-PROMOTE"
|
||||||
|
@ -49,6 +54,8 @@ let group_by_targets db =
|
||||||
(* Sort the list of possible sources for deterministic behavior *)
|
(* Sort the list of possible sources for deterministic behavior *)
|
||||||
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
|
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
|
||||||
|
|
||||||
|
let were_files_promoted = ref false
|
||||||
|
|
||||||
type files_to_promote =
|
type files_to_promote =
|
||||||
| All
|
| All
|
||||||
| These of Path.t list * (Path.t -> unit)
|
| 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 ->
|
List.iter dirs_to_clear_from_cache ~f:(fun dir ->
|
||||||
Utils.Cached_digest.remove (Path.append dir dst));
|
Utils.Cached_digest.remove (Path.append dir dst));
|
||||||
File.promote { src; dst };
|
File.promote { src; dst };
|
||||||
|
were_files_promoted := true;
|
||||||
List.iter others ~f:(fun path ->
|
List.iter others ~f:(fun path ->
|
||||||
Format.eprintf " -> ignored %s.@."
|
Format.eprintf " -> ignored %s.@."
|
||||||
(Path.to_string_maybe_quoted path))
|
(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 }))
|
List.map srcs ~f:(fun src -> { File.src; dst }))
|
||||||
|
|
||||||
let finalize () =
|
let finalize () =
|
||||||
|
were_files_promoted := false;
|
||||||
let db =
|
let db =
|
||||||
if !Clflags.auto_promote then
|
if !Clflags.auto_promote then
|
||||||
do_promote !File.db All
|
do_promote !File.db All
|
||||||
|
@ -114,6 +123,9 @@ let finalize () =
|
||||||
in
|
in
|
||||||
dump_db db
|
dump_db db
|
||||||
|
|
||||||
|
let were_files_promoted () =
|
||||||
|
!were_files_promoted
|
||||||
|
|
||||||
let promote_files_registered_in_last_run files_to_promote =
|
let promote_files_registered_in_last_run files_to_promote =
|
||||||
let db = load_db () in
|
let db = load_db () in
|
||||||
let db = do_promote db files_to_promote in
|
let db = do_promote db files_to_promote in
|
||||||
|
|
|
@ -14,6 +14,9 @@ end
|
||||||
dump the list of registered files to [_build/.to-promote]. *)
|
dump the list of registered files to [_build/.to-promote]. *)
|
||||||
val finalize : unit -> unit
|
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
|
(** Describe what files should be promoted. The second argument of
|
||||||
[These] is a function that is called on files that cannot be
|
[These] is a function that is called on files that cannot be
|
||||||
promoted. *)
|
promoted. *)
|
||||||
|
|
|
@ -118,6 +118,11 @@ let report_with_backtrace exn =
|
||||||
|
|
||||||
let reported = ref String.Set.empty
|
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 report exn =
|
||||||
let exn, dependency_path = Dep_path.unwrap_exn exn in
|
let exn, dependency_path = Dep_path.unwrap_exn exn in
|
||||||
match exn with
|
match exn with
|
||||||
|
|
110
src/scheduler.ml
110
src/scheduler.ml
|
@ -2,6 +2,11 @@ open! Stdune
|
||||||
open Import
|
open Import
|
||||||
open Fiber.O
|
open Fiber.O
|
||||||
|
|
||||||
|
type status_line_config =
|
||||||
|
{ message : string option
|
||||||
|
; show_jobs : bool
|
||||||
|
}
|
||||||
|
|
||||||
type running_job =
|
type running_job =
|
||||||
{ pid : int
|
{ pid : int
|
||||||
; ivar : Unix.process_status Fiber.Ivar.t
|
; ivar : Unix.process_status Fiber.Ivar.t
|
||||||
|
@ -66,7 +71,7 @@ type t =
|
||||||
; mutable concurrency : int
|
; mutable concurrency : int
|
||||||
; waiting_for_available_job : t Fiber.Ivar.t Queue.t
|
; waiting_for_available_job : t Fiber.Ivar.t Queue.t
|
||||||
; mutable status_line : string
|
; mutable status_line : string
|
||||||
; mutable gen_status_line : unit -> string option
|
; mutable gen_status_line : unit -> status_line_config
|
||||||
}
|
}
|
||||||
|
|
||||||
let log t = t.log
|
let log t = t.log
|
||||||
|
@ -136,13 +141,18 @@ let rec go_rec t =
|
||||||
end else begin
|
end else begin
|
||||||
if t.display = Progress then begin
|
if t.display = Progress then begin
|
||||||
match t.gen_status_line () with
|
match t.gen_status_line () with
|
||||||
| None ->
|
| { message = None; _ } ->
|
||||||
if t.status_line <> "" then begin
|
if t.status_line <> "" then begin
|
||||||
hide_status_line t.status_line;
|
hide_status_line t.status_line;
|
||||||
flush stderr
|
flush stderr
|
||||||
end
|
end
|
||||||
| Some status_line ->
|
| { message = Some status_line; show_jobs } ->
|
||||||
let status_line = sprintf "%s (jobs: %u)" status_line count in
|
let status_line =
|
||||||
|
if show_jobs then
|
||||||
|
sprintf "%s (jobs: %u)" status_line count
|
||||||
|
else
|
||||||
|
status_line
|
||||||
|
in
|
||||||
hide_status_line t.status_line;
|
hide_status_line t.status_line;
|
||||||
show_status_line status_line;
|
show_status_line status_line;
|
||||||
flush stderr;
|
flush stderr;
|
||||||
|
@ -156,8 +166,8 @@ let rec go_rec t =
|
||||||
go_rec t
|
go_rec t
|
||||||
end
|
end
|
||||||
|
|
||||||
let go ?(log=Log.no_log) ?(config=Config.default)
|
let prepare ?(log=Log.no_log) ?(config=Config.default)
|
||||||
?(gen_status_line=fun () -> None) fiber =
|
?(gen_status_line=fun () -> { message = None; show_jobs = false }) () =
|
||||||
Log.infof log "Workspace root: %s"
|
Log.infof log "Workspace root: %s"
|
||||||
(Path.to_absolute_filename Path.root |> String.maybe_quoted);
|
(Path.to_absolute_filename Path.root |> String.maybe_quoted);
|
||||||
let cwd = Sys.getcwd () in
|
let cwd = Sys.getcwd () in
|
||||||
|
@ -190,18 +200,102 @@ let go ?(log=Log.no_log) ?(config=Config.default)
|
||||||
{ log
|
{ log
|
||||||
; gen_status_line
|
; gen_status_line
|
||||||
; original_cwd = cwd
|
; original_cwd = cwd
|
||||||
; display = config.display
|
; display = config.Config.display
|
||||||
; concurrency = (match config.concurrency with Auto -> 1 | Fixed n -> n)
|
; concurrency = (match config.concurrency with Auto -> 1 | Fixed n -> n)
|
||||||
; status_line = ""
|
; status_line = ""
|
||||||
; waiting_for_available_job = Queue.create ()
|
; waiting_for_available_job = Queue.create ()
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
Errors.printer := print t;
|
Errors.printer := print t;
|
||||||
|
t
|
||||||
|
|
||||||
|
let run t fiber =
|
||||||
let fiber =
|
let fiber =
|
||||||
Fiber.Var.set t_var t
|
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
|
in
|
||||||
Fiber.run
|
Fiber.run
|
||||||
(Fiber.fork_and_join_unit
|
(Fiber.fork_and_join_unit
|
||||||
(fun () -> go_rec t)
|
(fun () -> go_rec t)
|
||||||
(fun () -> fiber))
|
(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
|
||||||
|
|
|
@ -2,21 +2,47 @@
|
||||||
|
|
||||||
open! Stdune
|
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
|
(** [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 =
|
terminates. [gen_status_line] is used to print a status line when [config.display =
|
||||||
Progress]. *)
|
Progress]. *)
|
||||||
val go
|
val go
|
||||||
: ?log:Log.t
|
: ?log:Log.t
|
||||||
-> ?config:Config.t
|
-> ?config:Config.t
|
||||||
-> ?gen_status_line:(unit -> string option)
|
-> ?gen_status_line:(unit -> status_line_config)
|
||||||
-> 'a Fiber.t
|
-> 'a Fiber.t
|
||||||
-> 'a
|
-> '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 *)
|
(** Wait for the following process to terminate *)
|
||||||
val wait_for_process : int -> Unix.process_status Fiber.t
|
val wait_for_process : int -> Unix.process_status Fiber.t
|
||||||
|
|
||||||
(** Set the status line generator for the current scheduler *)
|
(** 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
|
val set_concurrency : int -> unit Fiber.t
|
||||||
|
|
||||||
|
|
|
@ -68,6 +68,7 @@ let replace = replace
|
||||||
let length = length
|
let length = length
|
||||||
let remove = remove
|
let remove = remove
|
||||||
let mem = mem
|
let mem = mem
|
||||||
|
let reset = reset
|
||||||
|
|
||||||
let find = find_opt
|
let find = find_opt
|
||||||
|
|
||||||
|
|
|
@ -8,6 +8,8 @@ val hash : 'a -> int
|
||||||
|
|
||||||
val create : ?random:bool -> int -> ('a, 'b) t
|
val create : ?random:bool -> int -> ('a, 'b) t
|
||||||
|
|
||||||
|
val reset : ('a, 'b) t -> unit
|
||||||
|
|
||||||
val remove : ('a, _) t -> 'a -> unit
|
val remove : ('a, _) t -> 'a -> unit
|
||||||
|
|
||||||
val length : (_, _) t -> int
|
val length : (_, _) t -> int
|
||||||
|
|
Loading…
Reference in New Issue