Actions printed by "jbuilder rules" are now using relative paths

This seems more natural

bin/main.ml

@@ -842,6 +842,9 @@ let rules =
          | _  -> resolve_targets_exn ~log common setup targets |> request_of_targets setup
        in
        Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules ->
+       let sexp_of_action action =
+         Action.for_shell action |> Action.For_shell.sexp_of_t
+       in
        let print oc =
          let ppf = Format.formatter_of_out_channel oc in
          Sexp.prepare_formatter ppf;
@@ -855,7 +858,7 @@ let rules =
                (fun ppf ->
                   Path.Set.iter rule.deps ~f:(fun dep ->
                     Format.fprintf ppf "@ %s" (Path.to_string dep)))
-               Sexp.pp_split_strings (Action.sexp_of_t rule.action))
+               Sexp.pp_split_strings (sexp_of_action rule.action))
          end else begin
            List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
              let sexp =
@@ -867,7 +870,7 @@ let rules =
                    ; (match rule.context with
                       | None -> []
                       | Some c -> ["context", Atom c.name])
-                   ; [ "action" , Action.sexp_of_t rule.action ]
+                   ; [ "action" , sexp_of_action rule.action ]
                    ])
              in
              Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp)

src/action.ml

@@ -131,35 +131,35 @@ module Make_mapper
     (Src : Action_intf.Ast)
     (Dst : Action_intf.Ast)
 = struct
-  let rec map (t : Src.t) ~f_program ~f_string ~f_path : Dst.t =
+  let rec map (t : Src.t) ~dir ~f_program ~f_string ~f_path : Dst.t =
     match t with
     | Run (prog, args) ->
-      Run (f_program prog, List.map args ~f:f_string)
+      Run (f_program ~dir prog, List.map args ~f:(f_string ~dir))
     | Chdir (fn, t) ->
-      Chdir (f_path fn, map t ~f_program ~f_string ~f_path)
+      Chdir (f_path ~dir fn, map t ~dir:fn ~f_program ~f_string ~f_path)
     | Setenv (var, value, t) ->
-      Setenv (f_string var, f_string value, map t ~f_program ~f_string ~f_path)
+      Setenv (f_string ~dir var, f_string ~dir value, map t ~dir ~f_program ~f_string ~f_path)
     | Redirect (outputs, fn, t) ->
-      Redirect (outputs, f_path fn, map t ~f_program ~f_string ~f_path)
+      Redirect (outputs, f_path ~dir fn, map t ~dir ~f_program ~f_string ~f_path)
     | Ignore (outputs, t) ->
-      Ignore (outputs, map t ~f_program ~f_string ~f_path)
-    | Progn l -> Progn (List.map l ~f:(fun t -> map t ~f_program ~f_string ~f_path))
-    | Echo x -> Echo (f_string x)
-    | Cat x -> Cat (f_path x)
-    | Copy (x, y) -> Copy (f_path x, f_path y)
+      Ignore (outputs, map t ~dir ~f_program ~f_string ~f_path)
+    | Progn l -> Progn (List.map l ~f:(fun t -> map t ~dir ~f_program ~f_string ~f_path))
+    | Echo x -> Echo (f_string ~dir x)
+    | Cat x -> Cat (f_path ~dir x)
+    | Copy (x, y) -> Copy (f_path ~dir x, f_path ~dir y)
     | Symlink (x, y) ->
-      Symlink (f_path x, f_path y)
+      Symlink (f_path ~dir x, f_path ~dir y)
     | Copy_and_add_line_directive (x, y) ->
-      Copy_and_add_line_directive (f_path x, f_path y)
-    | System x -> System (f_string x)
-    | Bash x -> Bash (f_string x)
-    | Write_file (x, y) -> Write_file (f_path x, f_string y)
-    | Rename (x, y) -> Rename (f_path x, f_path y)
-    | Remove_tree x -> Remove_tree (f_path x)
-    | Mkdir x -> Mkdir (f_path x)
-    | Digest_files x -> Digest_files (List.map x ~f:f_path)
+      Copy_and_add_line_directive (f_path ~dir x, f_path ~dir y)
+    | System x -> System (f_string ~dir x)
+    | Bash x -> Bash (f_string ~dir x)
+    | Write_file (x, y) -> Write_file (f_path ~dir x, f_string ~dir y)
+    | Rename (x, y) -> Rename (f_path ~dir x, f_path ~dir y)
+    | Remove_tree x -> Remove_tree (f_path ~dir x)
+    | Mkdir x -> Mkdir (f_path ~dir x)
+    | Digest_files x -> Digest_files (List.map x ~f:(f_path ~dir))
     | Diff { optional; file1; file2 } ->
-      Diff { optional; file1 = f_path file1; file2 = f_path file2 }
+      Diff { optional; file1 = f_path ~dir file1; file2 = f_path ~dir file2 }
 end
 
 module Prog = struct
@@ -189,16 +189,44 @@ module type Ast = Action_intf.Ast
   with type string  = String.t
 module rec Ast : Ast = Ast
 
+module String_with_sexp = struct
+  type t = string
+  let t = Sexp.Of_sexp.string
+  let sexp_of_t = Sexp.To_sexp.string
+end
+
 include Make_ast
     (Prog)
     (Path)
-    (struct
-      type t = string
-      let t = Sexp.Of_sexp.string
-      let sexp_of_t = Sexp.To_sexp.string
-    end)
+    (String_with_sexp)
     (Ast)
 
+module For_shell = struct
+  module type Ast = Action_intf.Ast
+    with type program = string
+    with type path    = string
+    with type string  = string
+  module rec Ast : Ast = Ast
+
+  include Make_ast
+      (String_with_sexp)
+      (String_with_sexp)
+      (String_with_sexp)
+      (Ast)
+end
+
+module Relativise = Make_mapper(Ast)(For_shell.Ast)
+
+let for_shell t =
+  Relativise.map t
+    ~dir:Path.root
+    ~f_string:(fun ~dir:_ x -> x)
+    ~f_path:(fun ~dir x -> Path.reach x ~from:dir)
+    ~f_program:(fun ~dir x ->
+      match x with
+      | Ok p -> Path.reach p ~from:dir
+      | Error e -> e.program)
+
 module Unresolved = struct
   module Program = struct
     type t =
@@ -222,8 +250,11 @@ module Unresolved = struct
   include Make_mapper(Uast)(Ast)
 
   let resolve t ~f =
-    map t ~f_path:(fun x -> x) ~f_string:(fun x -> x)
-      ~f_program:(function
+    map t
+      ~dir:Path.root
+      ~f_path:(fun ~dir:_ x -> x)
+      ~f_string:(fun ~dir:_ x -> x)
+      ~f_program:(fun ~dir:_ -> function
         | This p -> Ok p
         | Search s -> Ok (f s))
 end
@@ -864,10 +895,11 @@ let sandbox t ~sandboxed ~deps ~targets =
           Some (Ast.Symlink (path, sandboxed path))
         else
           None))
-    ; map t ~f_string:(fun x -> x) ~f_path:sandboxed
-        ~f_program:(function
-        | Ok p -> Ok (sandboxed p)
-        | Error _ as e -> e)
+    ; map t
+        ~dir:Path.root
+        ~f_string:(fun ~dir:_ x -> x)
+        ~f_path:(fun ~dir:_ p -> sandboxed p)
+        ~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed)
     ; Progn (List.filter_map targets ~f:(fun path ->
         if Path.is_local path then
           Some (Ast.Rename (sandboxed path, path))

src/action.mli

@@ -42,7 +42,18 @@ include Action_intf.Helpers
   with type t       := t
 
 val t : t Sexp.Of_sexp.t
-val sexp_of_t : t Sexp.To_sexp.t
+
+module For_shell : sig
+  include Action_intf.Ast
+    with type program := string
+    with type path    := string
+    with type string  := string
+
+  val sexp_of_t : t Sexp.To_sexp.t
+end
+
+(** Convert the action to a format suitable for printing *)
+val for_shell : t -> For_shell.t
 
 (** Return the list of directories the action chdirs to *)
 val chdirs : t -> Path.Set.t