From 157ecaab60857c350b97b53ed405fc5e7bd30bbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 28 Feb 2017 23:23:51 +0000 Subject: [PATCH] Resolve path properly in actions --- src/build.ml | 66 ++++++++++++++++++++++++++++-------------------- src/build.mli | 5 ++-- src/gen_rules.ml | 51 ++++++++++++++++++++++--------------- 3 files changed, 73 insertions(+), 49 deletions(-) diff --git a/src/build.ml b/src/build.ml index 65552d5d..feab1dba 100644 --- a/src/build.ml +++ b/src/build.ml @@ -182,29 +182,39 @@ module Shexp = struct open Future open Action.Mini_shexp - let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail = + let run ~dir ~env ~env_extra ~stdout_to ~tail prog args = + let stdout_to : Future.stdout_to = + match stdout_to with + | None -> Terminal + | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc } + in + let env = Context.extend_env ~vars:env_extra ~env in + Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args + + let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f = match t with | Run (prog, args) -> - let stdout_to : Future.stdout_to = - match stdout_to with - | None -> Terminal - | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc } - in - let env = Context.extend_env ~vars:env_extra ~env in - Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args + let prog = f ~dir prog in + let args = List.map args ~f:(f ~dir) in + run ~dir ~env ~env_extra ~stdout_to ~tail prog args | Chdir (fn, t) -> - exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn) + let fn = f ~dir fn in + exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn) ~f | Setenv (var, value, t) -> - exec t ~dir ~env ~stdout_to ~tail + let var = f ~dir var in + let value = f ~dir value in + exec t ~dir ~env ~stdout_to ~tail ~f ~env_extra:(String_map.add env_extra ~key:var ~data:value) | With_stdout_to (fn, t) -> + let fn = f ~dir fn in if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); let fn = Path.to_string (Path.relative dir fn) in - exec t ~dir ~env ~env_extra ~tail + exec t ~dir ~env ~env_extra ~tail ~f ~stdout_to:(Some (fn, open_out_bin fn)) | Progn l -> - exec_list l ~dir ~env ~env_extra ~stdout_to ~tail + exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f | Echo str -> + let str = f ~dir str in return (match stdout_to with | None -> print_string str; flush stdout @@ -212,6 +222,7 @@ module Shexp = struct output_string oc str; if tail then close_out oc) | Cat fn -> + let fn = f ~dir fn in let fn = Path.to_string (Path.relative dir fn) in with_file_in fn ~f:(fun ic -> match stdout_to with @@ -221,8 +232,8 @@ module Shexp = struct if tail then close_out oc); return () | Copy_and_add_line_directive (src, dst) -> - let src = Path.relative dir src in - let dst = Path.relative dir dst in + let src = Path.relative dir (f ~dir src) in + let dst = Path.relative dir (f ~dir dst) in with_file_in (Path.to_string src) ~f:(fun ic -> with_file_out (Path.to_string dst) ~f:(fun oc -> let fn = @@ -234,38 +245,39 @@ module Shexp = struct copy_channels ic oc)); return () | System cmd -> + let cmd = f ~dir cmd in let path, arg, err = Utils.system_shell ~needed_to:"interpret (system ...) actions" in match err with | Some err -> err.fail () | None -> - exec ~dir ~env ~env_extra ~stdout_to ~tail - (Run (Path.to_string path, [arg; cmd])) + run ~dir ~env ~env_extra ~stdout_to ~tail + (Path.to_string path) [arg; cmd] - and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail = + and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f = match l with | [] -> if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); Future.return () | [t] -> - exec t ~dir ~env ~env_extra ~stdout_to ~tail + exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f | t :: rest -> - exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () -> - exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail + exec t ~dir ~env ~env_extra ~stdout_to ~tail:false ~f >>= fun () -> + exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail ~f - let exec t ~dir ~env = - exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true + let exec t ~dir ~env ~f = + exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true ~f end -let action ~dir ~env ~targets = - prim ~targets (fun action -> - match (action : string Action.t) with +let action action ~dir ~env ~targets = + prim ~targets (fun f -> + match (action : _ Action.t) with | Bash cmd -> Future.run Strict ~dir:(Path.to_string dir) ~env - "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] + "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; f ~dir cmd] | Shexp shexp -> - Shexp.exec ~dir ~env shexp) + Shexp.exec ~dir ~env ~f shexp) let echo fn = create_file ~target:fn (fun data -> diff --git a/src/build.mli b/src/build.mli index d2491db2..ff7774b4 100644 --- a/src/build.mli +++ b/src/build.mli @@ -79,10 +79,11 @@ val run_capture_lines -> ('a, string list) t val action - : dir:Path.t + : 'a Action.t + -> dir:Path.t -> env:string array -> targets:Path.t list - -> (string Action.t, unit) t + -> (dir:Path.t -> 'a -> string, unit) t (** Create a file with the given contents. *) val echo : Path.t -> (string, unit) t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 8efca83f..ae414b3a 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1270,21 +1270,26 @@ module Gen(P : Params) = struct +-----------------------------------------------------------------+ *) module Action_interpret : sig + type expander + val expand : Action.Unexpanded.t -> dir:Path.t -> dep_kind:Build.lib_dep_kind - -> targets:string list + -> targets:Path.t list -> deps:Dep_conf.t list - -> (unit, string Action.t) Build.t + -> (unit, expander) Build.t val run - : dir:Path.t + : Action.Unexpanded.t + -> dir:Path.t -> targets:Path.t list - -> (string Action.t, unit) Build.t + -> (expander, unit) Build.t end = struct module U = Action.Unexpanded + type expander = dir:Path.t -> String_with_vars.t -> string + type artefact = | Direct of Path.t | Dyn of (unit, Path.t) Build.t @@ -1301,31 +1306,36 @@ module Gen(P : Params) = struct String_map.add acc ~key:var ~data:(Dyn (N.in_findlib ~dir ~dep_kind s)) | _ -> acc) - let expand t ~artifact_map ~dir ~targets ~deps = - let dep_exn name = function - | Some dep -> dep + let expand_string_with_vars ~artifact_map ~targets ~deps : expander = + let dep_exn ~dir name = function + | Some dep -> Path.reach ~from:dir dep | None -> die "cannot use ${%s} with files_recursively_in" name in - let lookup var_name = + let lookup ~dir var_name = match String_map.find var_name artifact_map with | Some path -> Some (Path.reach ~from:dir path) | None -> match var_name with - | "@" -> Some (String.concat ~sep:" " targets) - | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn var_name dep1) + | "@" -> Some (String.concat ~sep:" " (List.map targets ~f:(Path.reach ~from:dir))) + | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn ~dir var_name dep1) | "^" -> - let deps = List.map deps ~f:(dep_exn var_name) in + let deps = List.map deps ~f:(dep_exn ~dir var_name) in Some (String.concat ~sep:" " deps) | _ -> root_var_lookup ~dir var_name in - U.expand t ~f:lookup + fun ~dir str -> + String_with_vars.expand str ~f:(lookup ~dir) let expand t ~dir ~dep_kind ~targets ~deps = - let deps = List.map deps ~f:(Dep_conf_interpret.only_plain_file ~dir) in + let deps = + List.map deps ~f:(fun dep -> + Option.map (Dep_conf_interpret.only_plain_file ~dir dep) + ~f:(Path.relative dir)) + in let needed_artifacts = extract_artifacts ~dir ~dep_kind t in if String_map.is_empty needed_artifacts then - let s = expand t ~dir ~artifact_map:String_map.empty ~targets ~deps in - Build.return s + let expand = expand_string_with_vars ~artifact_map:String_map.empty ~targets ~deps in + Build.return expand else begin let directs, dyns = String_map.bindings needed_artifacts @@ -1347,11 +1357,11 @@ module Gen(P : Params) = struct let artifact_map = String_map.of_alist_exn (List.rev_append directs artifacts) in - expand t ~dir ~artifact_map ~targets ~deps) + expand_string_with_vars ~artifact_map ~targets ~deps) end - let run ~dir ~targets = - Build.action ~dir ~env:ctx.env ~targets + let run action ~dir ~targets = + Build.action action ~dir ~env:ctx.env ~targets end (* +-----------------------------------------------------------------+ @@ -1367,10 +1377,11 @@ module Gen(P : Params) = struct rule.action ~dir ~dep_kind:Required - ~targets:rule.targets + ~targets ~deps:rule.deps >>> Action_interpret.run + rule.action ~dir ~targets) @@ -1402,7 +1413,7 @@ module Gen(P : Params) = struct ~dep_kind:Required ~targets:[] ~deps:alias_conf.deps - >>> Action_interpret.run ~dir ~targets:[] in + >>> Action_interpret.run action ~dir ~targets:[] in add_rule (deps >>> dummy) (* +-----------------------------------------------------------------+