diff --git a/bin/main.ml b/bin/main.ml index a95cd0e0..d2624ee5 100644 --- a/bin/main.ml +++ b/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) diff --git a/src/action.ml b/src/action.ml index c0da792a..00fe164e 100644 --- a/src/action.ml +++ b/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)) diff --git a/src/action.mli b/src/action.mli index 8dc0f943..93a77c73 100644 --- a/src/action.mli +++ b/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