matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move promotion to own module 

It's not really related to actions

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
Rudi Grinberg 2018-07-18 11:20:48 +02:00
parent bf2d842075
commit 1b71d57bba
6 changed files with 123 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/main.ml
View File

@ -1402,7 +1402,7 @@ let promote =
(* We load and restore the digest cache as we need to clear the
cache for promoted files, due to issues on OSX. *)
Utils.Cached_digest.load ();
Action_exec.Promotion.promote_files_registered_in_last_run ();
Promotion.promote_files_registered_in_last_run ();
Utils.Cached_digest.dump ()
in
(term, Term.info "promote" ~doc ~man )

106
src/action_exec.ml
View File

@ -6,112 +6,6 @@ type exec_context =
; purpose : Process.purpose
}
module Promotion = struct
module File = struct
type t =
{ src : Path.t
; dst : Path.t
}
(* XXX these sexp converters will be useful for the dump command *)
let _t =
let open Sexp.Of_sexp in
peek_exn >>= function
| List (_, [_; Atom (_, A "as"); _]) ->
enter
(Path.t >>= fun src ->
junk >>= fun () ->
Path.t >>= fun dst ->
return { src; dst })
| sexp ->
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
"(<file> as <file>) expected"
let _sexp_of_t { src; dst } =
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
Path.sexp_of_t dst]
let db : t list ref = ref []
let register t = db := t :: !db
let promote { src; dst } =
Format.eprintf "Promoting %s to %s.@."
(Path.to_string_maybe_quoted src)
(Path.to_string_maybe_quoted dst);
Io.copy_file ~src ~dst ()
end
module P = Utils.Persistent(struct
type t = File.t list
let name = "TO-PROMOTE"
let version = 1
end)
let db_file = Path.relative Path.build_dir ".to-promote"
let dump_db db =
if Path.build_dir_exists () then begin
match db with
| [] -> if Path.exists db_file then Path.unlink_no_err db_file
| l -> P.dump db_file l
end
let load_db () = Option.value ~default:[] (P.load db_file)
let group_by_targets db =
List.map db ~f:(fun { File. src; dst } ->
(dst, src))
|> Path.Map.of_list_multi
(* Sort the list of possible sources for deterministic behavior *)
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
let do_promote db =
let by_targets = group_by_targets db in
let potential_build_contexts =
match Path.readdir_unsorted Path.build_dir with
| exception _ -> []
| files ->
List.filter_map files ~f:(fun fn ->
if fn = "" || fn.[0] = '.' || fn = "install" then
None
else
let path = Path.(relative build_dir) fn in
Option.some_if (Path.is_directory path) path)
in
let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in
Path.Map.iteri by_targets ~f:(fun dst srcs ->
match srcs with
| [] -> assert false
| src :: others ->
(* We remove the files from the digest cache to force a rehash
on the next run. We do this because on OSX [mtime] is not
precise enough and if a file is modified and promoted
quickly, it will look like it hasn't changed even though it
might have. *)
List.iter dirs_to_clear_from_cache ~f:(fun dir ->
Utils.Cached_digest.remove (Path.append dir dst));
File.promote { src; dst };
List.iter others ~f:(fun path ->
Format.eprintf " -> ignored %s.@."
(Path.to_string_maybe_quoted path)))
let finalize () =
let db =
if !Clflags.auto_promote then
(do_promote !File.db; [])
else
!File.db
in
dump_db db
let promote_files_registered_in_last_run () =
let db = load_db () in
do_promote db;
dump_db []
end
let get_std_output : _ -> Process.std_output_to = function
| None -> Terminal
| Some (fn, oc) ->

18
src/action_exec.mli
View File

@ -1,23 +1,5 @@
open Stdune
module Promotion : sig
module File : sig
type t =
{ src : Path.t
; dst : Path.t
}
(** Register a file to promote *)
val register : t -> unit
end
(** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of
registered files to [_build/.to-promote]. *)
val finalize : unit -> unit
val promote_files_registered_in_last_run : unit -> unit
end
val exec
: targets:Path.Set.t
-> context:Context.t option

2
src/build_system.ml
View File

@ -1214,7 +1214,7 @@ let all_targets t =
let finalize t =
(* Promotion must be handled before dumping the digest cache, as it
might delete some entries. *)
Action_exec.Promotion.finalize ();
Promotion.finalize ();
Promoted_to_delete.dump ();
Utils.Cached_digest.dump ();
Trace.dump t.trace

104
src/promotion.ml Normal file
View File

@ -0,0 +1,104 @@
open Stdune
module File = struct
type t =
{ src : Path.t
; dst : Path.t
}
(* XXX these sexp converters will be useful for the dump command *)
let _t =
let open Sexp.Of_sexp in
peek_exn >>= function
| List (_, [_; Atom (_, A "as"); _]) ->
enter
(Path.t >>= fun src ->
junk >>= fun () ->
Path.t >>= fun dst ->
return { src; dst })
| sexp ->
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
"(<file> as <file>) expected"
let _sexp_of_t { src; dst } =
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
Path.sexp_of_t dst]
let db : t list ref = ref []
let register t = db := t :: !db
let promote { src; dst } =
Format.eprintf "Promoting %s to %s.@."
(Path.to_string_maybe_quoted src)
(Path.to_string_maybe_quoted dst);
Io.copy_file ~src ~dst ()
end
module P = Utils.Persistent(struct
type t = File.t list
let name = "TO-PROMOTE"
let version = 1
end)
let db_file = Path.relative Path.build_dir ".to-promote"
let dump_db db =
if Path.build_dir_exists () then begin
match db with
| [] -> if Path.exists db_file then Path.unlink_no_err db_file
| l -> P.dump db_file l
end
let load_db () = Option.value ~default:[] (P.load db_file)
let group_by_targets db =
List.map db ~f:(fun { File. src; dst } ->
(dst, src))
|> Path.Map.of_list_multi
(* Sort the list of possible sources for deterministic behavior *)
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
let do_promote db =
let by_targets = group_by_targets db in
let potential_build_contexts =
match Path.readdir_unsorted Path.build_dir with
| exception _ -> []
| files ->
List.filter_map files ~f:(fun fn ->
if fn = "" || fn.[0] = '.' || fn = "install" then
None
else
let path = Path.(relative build_dir) fn in
Option.some_if (Path.is_directory path) path)
in
let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in
Path.Map.iteri by_targets ~f:(fun dst srcs ->
match srcs with
| [] -> assert false
| src :: others ->
(* We remove the files from the digest cache to force a rehash
on the next run. We do this because on OSX [mtime] is not
precise enough and if a file is modified and promoted
quickly, it will look like it hasn't changed even though it
might have. *)
List.iter dirs_to_clear_from_cache ~f:(fun dir ->
Utils.Cached_digest.remove (Path.append dir dst));
File.promote { src; dst };
List.iter others ~f:(fun path ->
Format.eprintf " -> ignored %s.@."
(Path.to_string_maybe_quoted path)))
let finalize () =
let db =
if !Clflags.auto_promote then
(do_promote !File.db; [])
else
!File.db
in
dump_db db
let promote_files_registered_in_last_run () =
let db = load_db () in
do_promote db;
dump_db []

17
src/promotion.mli Normal file
View File

@ -0,0 +1,17 @@
open Stdune
module File : sig
type t =
{ src : Path.t
; dst : Path.t
}
(** Register a file to promote *)
val register : t -> unit
end
(** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of
registered files to [_build/.to-promote]. *)
val finalize : unit -> unit
val promote_files_registered_in_last_run : unit -> unit