From 87c958f2e0369189e3724678928b33dabf865ba9 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 12 May 2017 15:05:07 +0100 Subject: [PATCH] Add Build.if_file_exists --- src/action.ml | 6 +----- src/build.ml | 24 ++++++++++++++++++++++++ src/build.mli | 23 +++++++++++++++++++++++ src/build_interpret.ml | 29 +++++++++++++++++++++++++++++ src/build_system.ml | 2 ++ src/gen_rules.ml | 4 +++- 6 files changed, 82 insertions(+), 6 deletions(-) diff --git a/src/action.ml b/src/action.ml index 8a5c9b87..9b0a3ae0 100644 --- a/src/action.ml +++ b/src/action.ml @@ -342,11 +342,7 @@ module Mini_shexp = struct | Copy_and_add_line_directive (src, dst) -> with_file_in (Path.to_string src) ~f:(fun ic -> with_file_out (Path.to_string dst) ~f:(fun oc -> - let fn = - match Path.extract_build_context src with - | None -> src - | Some (_, rem) -> rem - in + let fn = Path.drop_build_context src in Printf.fprintf oc "# 1 %S\n" (Path.to_string fn); copy_channels ic oc)); return () diff --git a/src/build.ml b/src/build.ml index 45209711..1b6a25cf 100644 --- a/src/build.ml +++ b/src/build.ml @@ -34,12 +34,23 @@ module Repr = struct | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t | Paths : Pset.t -> ('a, 'a) t | Paths_glob : Path.t * Re.re -> ('a, 'a) t + (* The reference gets decided in Build_interpret.deps *) + | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t | Contents : Path.t -> ('a, string) t | Lines_of : Path.t -> ('a, string list) t | Vpath : 'a Vspec.t -> (unit, 'a) t | Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t | Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t | Fail : fail -> (_, _) t + + and ('a, 'b) if_file_exists_state = + | Undecided of ('a, 'b) t * ('a, 'b) t + | Decided of bool * ('a, 'b) t + + let get_if_file_exists_exn state = + match !state with + | Decided (_, t) -> t + | Undecided _ -> code_errorf "Build.get_if_file_exists_exn: got undecided" end include Repr let repr t = t @@ -108,6 +119,19 @@ let dyn_paths t = Dyn_paths t let contents p = Contents p let lines_of p = Lines_of p +let if_file_exists p ~then_ ~else_ = + If_file_exists (p, ref (Undecided (then_, else_))) + +let file_exists p = + if_file_exists p + ~then_:(arr (fun _ -> true)) + ~else_:(arr (fun _ -> false)) + +let file_exists_opt p t = + if_file_exists p + ~then_:(t >>^ fun x -> Some x) + ~else_:(arr (fun _ -> None)) + let fail ?targets x = match targets with | None -> Fail x diff --git a/src/build.mli b/src/build.mli index 1edc82d7..07c2515c 100644 --- a/src/build.mli +++ b/src/build.mli @@ -45,6 +45,22 @@ val dyn_paths : ('a, Path.t list) t -> ('a, 'a) t val contents : Path.t -> ('a, string) t val lines_of : Path.t -> ('a, string list) t +(** Evaluates to [true] if the file is present on the file system or is the target of a + rule. *) +val file_exists : Path.t -> ('a, bool) t + +(** [if_file_exists p ~then ~else] is an arrow that behaves like [then_] if [file_exists + p] evaluates to [true], and [else_] otherwise. *) +val if_file_exists : Path.t -> then_:('a, 'b) t -> else_:('a, 'b) t -> ('a, 'b) t + +(** [file_exists_opt p t] is: + + {[ + if_file_exists p ~then_:(t >>^ fun x -> Some x) ~else_:(arr (fun _ -> None)) + ]} +*) +val file_exists_opt : Path.t -> ('a, 'b) t -> ('a, 'b option) t + (** Always fail when executed. We pass a function rather than an exception to get a proper backtrace *) val fail : ?targets:Path.t list -> fail -> (_, _) t @@ -126,12 +142,19 @@ module Repr : sig | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t | Paths : Path.Set.t -> ('a, 'a) t | Paths_glob : Path.t * Re.re -> ('a, 'a) t + | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t | Contents : Path.t -> ('a, string) t | Lines_of : Path.t -> ('a, string list) t | Vpath : 'a Vspec.t -> (unit, 'a) t | Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t | Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t | Fail : fail -> (_, _) t + + and ('a, 'b) if_file_exists_state = + | Undecided of ('a, 'b) t * ('a, 'b) t + | Decided of bool * ('a, 'b) t + + val get_if_file_exists_exn : ('a, 'b) if_file_exists_state ref -> ('a, 'b) t end val repr : ('a, 'b) t -> ('a, 'b) Repr.t diff --git a/src/build_interpret.ml b/src/build_interpret.ml index b5207bfd..105c2254 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -40,6 +40,23 @@ let deps t ~all_targets_by_dir = Re.execp re (Path.basename path)) |> Pset.union acc end + | If_file_exists (p, state) -> begin + match !state with + | Decided (exists, t) -> loop t (if exists then Pset.add p acc else acc) + | Undecided (then_, else_) -> + let dir = Path.parent p in + let targets = + Option.value (Pmap.find dir (Lazy.force all_targets_by_dir)) + ~default:Pset.empty + in + if Pset.mem p targets then begin + state := Decided (true, then_); + loop then_ (Pset.add p acc) + end else begin + state := Decided (false, else_); + loop else_ acc + end + end | Dyn_paths t -> loop t acc | Contents p -> Pset.add p acc | Lines_of p -> Pset.add p acc @@ -74,6 +91,8 @@ let lib_deps = in Pmap.add acc ~key:dir ~data | Fail _ -> acc + | If_file_exists (_, state) -> + loop (get_if_file_exists_exn state) acc in fun t -> loop (Build.repr t) Pmap.empty @@ -97,6 +116,16 @@ let targets = | Lines_of _ -> acc | Record_lib_deps _ -> acc | Fail _ -> acc + | If_file_exists (_, state) -> begin + match !state with + | Decided _ -> code_errorf "Build_interpret.targets got decided if_file_exists" + | Undecided (a, b) -> + match loop a [], loop b [] with + | [], [] -> acc + | _ -> + code_errorf "Build_interpret.targets: cannot have targets \ + under a [if_file_exists]" + end in fun t -> loop (Build.repr t) [] diff --git a/src/build_system.ml b/src/build_system.ml index 85b61567..1e62852f 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -248,6 +248,8 @@ module Build_exec = struct x | Record_lib_deps _ -> x | Fail { fail } -> fail () + | If_file_exists (_, state) -> + exec (get_if_file_exists_exn state) x in let action = exec (Build.repr t) x in (action, !dyn_deps) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index d307a64b..eec3979f 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -639,7 +639,9 @@ module Gen(P : Params) = struct let meta_fn = "META." ^ pkg.name in let meta_templ_fn = meta_fn ^ ".template" in - let files = SC.sources_and_targets_known_so_far sctx ~src_path:pkg.path in + let files = + SC.sources_and_targets_known_so_far sctx ~src_path:pkg.path + in let has_meta, has_meta_tmpl = (String_set.mem meta_fn files, String_set.mem meta_templ_fn files)