Resolve path properly in actions

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 =
+      let prog = f ~dir prog in
-        match stdout_to with
+      let args = List.map args ~f:(f ~dir) in
-        | None          -> Terminal
+      run ~dir ~env ~env_extra ~stdout_to ~tail prog args
-        | 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
     | 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 src = Path.relative dir (f ~dir src) in
-      let dst = Path.relative dir dst 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 ~dir ~env ~env_extra ~stdout_to ~tail
-          (Run (Path.to_string path, [arg; cmd]))
+          (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 t ~dir ~env ~env_extra ~stdout_to ~tail:false ~f >>= fun () ->
-      exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
+      exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail ~f
 
-  let exec t ~dir ~env =
+  let exec t ~dir ~env ~f =
-    exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true
+    exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true ~f
 end
 
-let action ~dir ~env ~targets =
+let action action ~dir ~env ~targets =
-  prim ~targets (fun action ->
+  prim ~targets (fun f ->
-    match (action : string Action.t) with
+    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 ->

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

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 expand_string_with_vars ~artifact_map ~targets ~deps : expander =
-      let dep_exn name = function
+      let dep_exn ~dir name = function
-        | Some dep -> dep
+        | 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 (String.concat ~sep:" " (List.map targets ~f:(Path.reach ~from:dir)))
-          | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn var_name dep1)
+          | "<" -> 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
+        let expand = expand_string_with_vars ~artifact_map:String_map.empty ~targets ~deps in
-        Build.return s
+        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 =
+    let run action ~dir ~targets =
-      Build.action ~dir ~env:ctx.env ~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)
 
   (* +-----------------------------------------------------------------+