matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move the context out of Action.t 

And add it to the rule. It is never dynamic, so it is simpler this
way, we just set it in Super_context.add_rule.
This commit is contained in:
Jérémie Dimino 2017-05-28 00:48:48 +01:00
parent 7f0a2d7e12
commit 73a4cef9f8
15 changed files with 494 additions and 523 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
bin/main.ml
View File

@ -585,7 +585,7 @@ let rules =
(fun ppf -> (fun ppf ->
Path.Set.iter rule.deps ~f:(fun dep -> Path.Set.iter rule.deps ~f:(fun dep ->
Format.fprintf ppf "@ %s" (Path.to_string dep))) Format.fprintf ppf "@ %s" (Path.to_string dep)))
Sexp.pp_split_strings (Action.Mini_shexp.sexp_of_t rule.action.action)) Sexp.pp_split_strings (Action.sexp_of_t rule.action))
end else begin end else begin
List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
let sexp = let sexp =
@ -594,10 +594,10 @@ let rules =
List.concat List.concat
[ [ "deps" , paths rule.deps [ [ "deps" , paths rule.deps
; "targets", paths rule.targets ] ; "targets", paths rule.targets ]
; (match rule.action.context with ; (match rule.context with
| None -> [] | None -> []
| Some c -> ["context", Atom c.name]) | Some c -> ["context", Atom c.name])
; [ "action" , Action.Mini_shexp.sexp_of_t rule.action.action ] ; [ "action" , Action.sexp_of_t rule.action ]
]) ])
in in
Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp) Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp)

2
jbuild-workspace.dev
View File

@ -1,6 +1,6 @@
;; This file is used by `make all-supported-ocaml-versions` ;; This file is used by `make all-supported-ocaml-versions`
(context ((switch 4.02.3))) (context ((switch 4.02.3)))
(context ((switch 4.03.0))) (context ((switch 4.03.0)))
(context ((switch 4.04.0))) (context ((switch 4.04.1)))
(context ((switch 4.05.0+trunk))) (context ((switch 4.05.0+trunk)))
(context ((switch 4.06.0+trunk))) (context ((switch 4.06.0+trunk)))

714
src/action.ml
View File

@ -53,412 +53,384 @@ let expand_prog ctx ~dir ~f template =
|> String.concat ~sep:" " |> String.concat ~sep:" "
|> resolve |> resolve
module Mini_shexp = struct module Ast = struct
module Ast = struct type outputs =
type outputs = | Stdout
| Stdout | Stderr
| Stderr | Outputs (* Both Stdout and Stderr *)
| Outputs (* Both Stdout and Stderr *)
let string_of_outputs = function let string_of_outputs = function
| Stdout -> "stdout" | Stdout -> "stdout"
| Stderr -> "stderr" | Stderr -> "stderr"
| Outputs -> "outputs" | Outputs -> "outputs"
type ('a, 'path) t = type ('a, 'path) t =
| Run of 'path * 'a list | Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t | Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t | Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t | Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t | Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list | Progn of ('a, 'path) t list
| Echo of 'a | Echo of 'a
| Create_file of 'path | Create_file of 'path
| Cat of 'path | Cat of 'path
| Copy of 'path * 'path | Copy of 'path * 'path
| Symlink of 'path * 'path | Symlink of 'path * 'path
| Copy_and_add_line_directive of 'path * 'path | Copy_and_add_line_directive of 'path * 'path
| System of 'a | System of 'a
| Bash of 'a | Bash of 'a
| Update_file of 'path * 'a | Update_file of 'path * 'a
| Rename of 'path * 'path | Rename of 'path * 'path
| Remove_tree of 'path | Remove_tree of 'path
let rec t a p sexp = let rec t a p sexp =
sum sum
[ cstr_rest "run" (p @> nil) a (fun prog args -> Run (prog, args)) [ cstr_rest "run" (p @> nil) a (fun prog args -> Run (prog, args))
; cstr "chdir" (p @> t a p @> nil) (fun dn t -> Chdir (dn, t)) ; cstr "chdir" (p @> t a p @> nil) (fun dn t -> Chdir (dn, t))
; cstr "setenv" (a @> a @> t a p @> nil) (fun k v t -> Setenv (k, v, t)) ; cstr "setenv" (a @> a @> t a p @> nil) (fun k v t -> Setenv (k, v, t))
; cstr "with-stdout-to" (p @> t a p @> nil) (fun fn t -> Redirect (Stdout, fn, t)) ; cstr "with-stdout-to" (p @> t a p @> nil) (fun fn t -> Redirect (Stdout, fn, t))
; cstr "with-stderr-to" (p @> t a p @> nil) (fun fn t -> Redirect (Stderr, fn, t)) ; cstr "with-stderr-to" (p @> t a p @> nil) (fun fn t -> Redirect (Stderr, fn, t))
; cstr "with-outputs-to" (p @> t a p @> nil) (fun fn t -> Redirect (Outputs, fn, t)) ; cstr "with-outputs-to" (p @> t a p @> nil) (fun fn t -> Redirect (Outputs, fn, t))
; cstr "ignore-stdout" (t a p @> nil) (fun t -> Ignore (Stdout, t)) ; cstr "ignore-stdout" (t a p @> nil) (fun t -> Ignore (Stdout, t))
; cstr "ignore-stderr" (t a p @> nil) (fun t -> Ignore (Stderr, t)) ; cstr "ignore-stderr" (t a p @> nil) (fun t -> Ignore (Stderr, t))
; cstr "ignore-outputs" (t a p @> nil) (fun t -> Ignore (Outputs, t)) ; cstr "ignore-outputs" (t a p @> nil) (fun t -> Ignore (Outputs, t))
; cstr_rest "progn" nil (t a p) (fun l -> Progn l) ; cstr_rest "progn" nil (t a p) (fun l -> Progn l)
; cstr "echo" (a @> nil) (fun x -> Echo x) ; cstr "echo" (a @> nil) (fun x -> Echo x)
; cstr "cat" (p @> nil) (fun x -> Cat x) ; cstr "cat" (p @> nil) (fun x -> Cat x)
; cstr "create-file" (p @> nil) (fun x -> Create_file x) ; cstr "create-file" (p @> nil) (fun x -> Create_file x)
; cstr "copy" (p @> p @> nil) (fun src dst -> Copy (src, dst)) ; cstr "copy" (p @> p @> nil) (fun src dst -> Copy (src, dst))
(* (*
(* We don't expose symlink to the user yet since this might complicate things *) (* We don't expose symlink to the user yet since this might complicate things *)
; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src)) ; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
*) *)
; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst -> ; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst)) Copy_and_add_line_directive (src, dst))
; cstr "system" (a @> nil) (fun cmd -> System cmd) ; cstr "system" (a @> nil) (fun cmd -> System cmd)
; cstr "bash" (a @> nil) (fun cmd -> Bash cmd) ; cstr "bash" (a @> nil) (fun cmd -> Bash cmd)
] ]
sexp sexp
let rec sexp_of_t f g : _ -> Sexp.t = function let rec sexp_of_t f g : _ -> Sexp.t = function
| Run (a, xs) -> List (Atom "run" :: g a :: List.map xs ~f) | Run (a, xs) -> List (Atom "run" :: g a :: List.map xs ~f)
| Chdir (a, r) -> List [Atom "chdir" ; g a ; sexp_of_t f g r] | Chdir (a, r) -> List [Atom "chdir" ; g a ; sexp_of_t f g r]
| Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r] | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r]
| Redirect (outputs, fn, r) -> | Redirect (outputs, fn, r) ->
List [ Atom (sprintf "with-%s-to" (string_of_outputs outputs)) List [ Atom (sprintf "with-%s-to" (string_of_outputs outputs))
; g fn ; g fn
; sexp_of_t f g r ; sexp_of_t f g r
] ]
| Ignore (outputs, r) -> | Ignore (outputs, r) ->
List [ Atom (sprintf "ignore-%s" (string_of_outputs outputs)) List [ Atom (sprintf "ignore-%s" (string_of_outputs outputs))
; sexp_of_t f g r ; sexp_of_t f g r
] ]
| Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g)) | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
| Echo x -> List [Atom "echo"; f x] | Echo x -> List [Atom "echo"; f x]
| Cat x -> List [Atom "cat"; g x] | Cat x -> List [Atom "cat"; g x]
| Create_file x -> List [Atom "create-file"; g x] | Create_file x -> List [Atom "create-file"; g x]
| Copy (x, y) -> | Copy (x, y) ->
List [Atom "copy"; g x; g y] List [Atom "copy"; g x; g y]
| Symlink (x, y) -> | Symlink (x, y) ->
List [Atom "symlink"; g x; g y] List [Atom "symlink"; g x; g y]
| Copy_and_add_line_directive (x, y) -> | Copy_and_add_line_directive (x, y) ->
List [Atom "copy-and-add-line-directive"; g x; g y] List [Atom "copy-and-add-line-directive"; g x; g y]
| System x -> List [Atom "system"; f x] | System x -> List [Atom "system"; f x]
| Bash x -> List [Atom "bash"; f x] | Bash x -> List [Atom "bash"; f x]
| Update_file (x, y) -> List [Atom "update-file"; g x; f y] | Update_file (x, y) -> List [Atom "update-file"; g x; f y]
| Rename (x, y) -> List [Atom "rename"; g x; g y] | Rename (x, y) -> List [Atom "rename"; g x; g y]
| Remove_tree x -> List [Atom "remove-tree"; g x] | Remove_tree x -> List [Atom "remove-tree"; g x]
let rec fold t ~init:acc ~f = let rec fold t ~init:acc ~f =
match t with match t with
| Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f | Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
| Chdir (fn, t) -> fold t ~init:(f acc fn) ~f | Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
| Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f | Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
| Redirect (_, fn, t) -> fold t ~init:(f acc fn) ~f | Redirect (_, fn, t) -> fold t ~init:(f acc fn) ~f
| Ignore (_, t) -> fold t ~init:acc ~f | Ignore (_, t) -> fold t ~init:acc ~f
| Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f) | Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
| Echo x -> f acc x | Echo x -> f acc x
| Cat x -> f acc x | Cat x -> f acc x
| Create_file x -> f acc x | Create_file x -> f acc x
| Copy (x, y) -> f (f acc x) y | Copy (x, y) -> f (f acc x) y
| Symlink (x, y) -> f (f acc x) y | Symlink (x, y) -> f (f acc x) y
| Copy_and_add_line_directive (x, y) -> f (f acc x) y | Copy_and_add_line_directive (x, y) -> f (f acc x) y
| System x -> f acc x | System x -> f acc x
| Bash x -> f acc x | Bash x -> f acc x
| Update_file (x, y) -> f (f acc x) y | Update_file (x, y) -> f (f acc x) y
| Rename (x, y) -> f (f acc x) y | Rename (x, y) -> f (f acc x) y
| Remove_tree x -> f acc x | Remove_tree x -> f acc x
let fold_one_step t ~init:acc ~f = let fold_one_step t ~init:acc ~f =
match t with match t with
| Chdir (_, t) | Chdir (_, t)
| Setenv (_, _, t) | Setenv (_, _, t)
| Redirect (_, _, t) | Redirect (_, _, t)
| Ignore (_, t) -> f acc t | Ignore (_, t) -> f acc t
| Progn l -> List.fold_left l ~init:acc ~f | Progn l -> List.fold_left l ~init:acc ~f
| Run _ | Run _
| Echo _ | Echo _
| Cat _ | Cat _
| Create_file _ | Create_file _
| Copy _ | Copy _
| Symlink _ | Symlink _
| Copy_and_add_line_directive _ | Copy_and_add_line_directive _
| System _ | System _
| Bash _ | Bash _
| Update_file _ | Update_file _
| Rename _ | Rename _
| Remove_tree _ -> acc | Remove_tree _ -> acc
let rec map let rec map
: 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t : 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t
= fun t ~f1 ~f2 -> = fun t ~f1 ~f2 ->
match t with
| Run (prog, args) ->
Run (f2 prog, List.map args ~f:f1)
| Chdir (fn, t) ->
Chdir (f2 fn, map t ~f1 ~f2)
| Setenv (var, value, t) ->
Setenv (f1 var, f1 value, map t ~f1 ~f2)
| Redirect (outputs, fn, t) ->
Redirect (outputs, f2 fn, map t ~f1 ~f2)
| Ignore (outputs, t) ->
Ignore (outputs, map t ~f1 ~f2)
| Progn l -> Progn (List.map l ~f:(fun t -> map t ~f1 ~f2))
| Echo x -> Echo (f1 x)
| Cat x -> Cat (f2 x)
| Create_file x -> Create_file (f2 x)
| Copy (x, y) -> Copy (f2 x, f2 y)
| Symlink (x, y) ->
Symlink (f2 x, f2 y)
| Copy_and_add_line_directive (x, y) ->
Copy_and_add_line_directive (f2 x, f2 y)
| System x -> System (f1 x)
| Bash x -> Bash (f1 x)
| Update_file (x, y) -> Update_file (f2 x, f1 y)
| Rename (x, y) -> Rename (f2 x, f2 y)
| Remove_tree x -> Remove_tree (f2 x)
end
open Ast
type t = (string, Path.t) Ast.t
let t = Ast.t string Path.t
let sexp_of_t = Ast.sexp_of_t Sexp.To_sexp.string Path.sexp_of_t
let updated_files =
let rec loop acc t =
let acc =
match t with
| Update_file (fn, _) -> Path.Set.add fn acc
| _ -> acc
in
Ast.fold_one_step t ~init:acc ~f:loop
in
fun t -> loop Path.Set.empty t
let chdirs =
let rec loop acc t =
let acc =
match t with
| Chdir (dir, _) -> Path.Set.add dir acc
| _ -> acc
in
Ast.fold_one_step t ~init:acc ~f:loop
in
fun t -> loop Path.Set.empty t
module Unexpanded = struct
type t = (String_with_vars.t, String_with_vars.t) Ast.t
let sexp_of_t = Ast.sexp_of_t String_with_vars.sexp_of_t String_with_vars.sexp_of_t
let t sexp =
match sexp with
| Atom _ ->
of_sexp_errorf sexp
"if you meant for this to be executed with bash, write (bash \"...\") instead"
| List _ -> Ast.t String_with_vars.t String_with_vars.t sexp
let fold_vars t ~init ~f =
Ast.fold t ~init ~f:(fun acc pat ->
String_with_vars.fold ~init:acc pat ~f)
let rec expand ctx dir t ~f : (string, Path.t) Ast.t =
match t with match t with
| Run (prog, args) -> | Run (prog, args) ->
Run (expand_prog ctx ~dir ~f prog, Run (f2 prog, List.map args ~f:f1)
List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
| Chdir (fn, t) -> | Chdir (fn, t) ->
let fn = expand_path ~dir ~f fn in Chdir (f2 fn, map t ~f1 ~f2)
Chdir (fn, expand ctx fn t ~f)
| Setenv (var, value, t) -> | Setenv (var, value, t) ->
Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value, Setenv (f1 var, f1 value, map t ~f1 ~f2)
expand ctx dir t ~f)
| Redirect (outputs, fn, t) -> | Redirect (outputs, fn, t) ->
Redirect (outputs, expand_path ~dir ~f fn, expand ctx dir t ~f) Redirect (outputs, f2 fn, map t ~f1 ~f2)
| Ignore (outputs, t) -> | Ignore (outputs, t) ->
Ignore (outputs, expand ctx dir t ~f) Ignore (outputs, map t ~f1 ~f2)
| Progn l -> Progn (List.map l ~f:(fun t -> expand ctx dir t ~f)) | Progn l -> Progn (List.map l ~f:(fun t -> map t ~f1 ~f2))
| Echo x -> Echo (expand_str ~dir ~f x) | Echo x -> Echo (f1 x)
| Cat x -> Cat (expand_path ~dir ~f x) | Cat x -> Cat (f2 x)
| Create_file x -> Create_file (expand_path ~dir ~f x) | Create_file x -> Create_file (f2 x)
| Copy (x, y) -> | Copy (x, y) -> Copy (f2 x, f2 y)
Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Symlink (x, y) -> | Symlink (x, y) ->
Symlink (expand_path ~dir ~f x, expand_path ~dir ~f y) Symlink (f2 x, f2 y)
| Copy_and_add_line_directive (x, y) -> | Copy_and_add_line_directive (x, y) ->
Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y) Copy_and_add_line_directive (f2 x, f2 y)
| System x -> System (expand_str ~dir ~f x) | System x -> System (f1 x)
| Bash x -> Bash (expand_str ~dir ~f x) | Bash x -> Bash (f1 x)
| Update_file (x, y) -> Update_file (expand_path ~dir ~f x, expand_str ~dir ~f y) | Update_file (x, y) -> Update_file (f2 x, f1 y)
| Rename (x, y) -> | Rename (x, y) -> Rename (f2 x, f2 y)
Rename (expand_path ~dir ~f x, expand_path ~dir ~f y) | Remove_tree x -> Remove_tree (f2 x)
| Remove_tree x -> end
Remove_tree (expand_path ~dir ~f x) open Ast
end
open Future type t = (string, Path.t) Ast.t
let t = Ast.t string Path.t
let sexp_of_t = Ast.sexp_of_t Sexp.To_sexp.string Path.sexp_of_t
let get_std_output : _ -> Future.std_output_to = function let updated_files =
| None -> Terminal let rec loop acc t =
| Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc } let acc =
match t with
| Update_file (fn, _) -> Path.Set.add fn acc
| _ -> acc
in
Ast.fold_one_step t ~init:acc ~f:loop
in
fun t -> loop Path.Set.empty t
let run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args = let chdirs =
let stdout_to = get_std_output stdout_to in let rec loop acc t =
let stderr_to = get_std_output stderr_to in let acc =
let env = Context.extend_env ~vars:env_extra ~env in match t with
Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to ~purpose | Chdir (dir, _) -> Path.Set.add dir acc
(Path.reach_for_running ~from:dir prog) args | _ -> acc
in
Ast.fold_one_step t ~init:acc ~f:loop
in
fun t -> loop Path.Set.empty t
let rec exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to = module Unexpanded = struct
type t = (String_with_vars.t, String_with_vars.t) Ast.t
let sexp_of_t = Ast.sexp_of_t String_with_vars.sexp_of_t String_with_vars.sexp_of_t
let t sexp =
match sexp with
| Atom _ ->
of_sexp_errorf sexp
"if you meant for this to be executed with bash, write (bash \"...\") instead"
| List _ -> Ast.t String_with_vars.t String_with_vars.t sexp
let fold_vars t ~init ~f =
Ast.fold t ~init ~f:(fun acc pat ->
String_with_vars.fold ~init:acc pat ~f)
let rec expand ctx dir t ~f : (string, Path.t) Ast.t =
match t with match t with
| Run (prog, args) -> | Run (prog, args) ->
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args Run (expand_prog ctx ~dir ~f prog,
| Chdir (dir, t) -> List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
exec t ~purpose ~env ~env_extra ~stdout_to ~stderr_to ~dir | Chdir (fn, t) ->
let fn = expand_path ~dir ~f fn in
Chdir (fn, expand ctx fn t ~f)
| Setenv (var, value, t) -> | Setenv (var, value, t) ->
exec t ~purpose ~dir ~env ~stdout_to ~stderr_to Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value,
~env_extra:(Env_var_map.add env_extra ~key:var ~data:value) expand ctx dir t ~f)
| Redirect (outputs, fn, t) -> | Redirect (outputs, fn, t) ->
redirect ~purpose outputs fn t ~dir ~env ~env_extra ~stdout_to ~stderr_to Redirect (outputs, expand_path ~dir ~f fn, expand ctx dir t ~f)
| Ignore (outputs, t) -> | Ignore (outputs, t) ->
redirect ~purpose outputs Config.dev_null t ~dir ~env ~env_extra ~stdout_to ~stderr_to Ignore (outputs, expand ctx dir t ~f)
| Progn l -> | Progn l -> Progn (List.map l ~f:(fun t -> expand ctx dir t ~f))
exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to | Echo x -> Echo (expand_str ~dir ~f x)
| Echo str -> | Cat x -> Cat (expand_path ~dir ~f x)
return | Create_file x -> Create_file (expand_path ~dir ~f x)
(match stdout_to with | Copy (x, y) ->
| None -> print_string str; flush stdout Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Some (_, oc) -> output_string oc str) | Symlink (x, y) ->
| Cat fn -> Symlink (expand_path ~dir ~f x, expand_path ~dir ~f y)
Io.with_file_in (Path.to_string fn) ~f:(fun ic -> | Copy_and_add_line_directive (x, y) ->
let oc = Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y)
match stdout_to with | System x -> System (expand_str ~dir ~f x)
| None -> stdout | Bash x -> Bash (expand_str ~dir ~f x)
| Some (_, oc) -> oc | Update_file (x, y) -> Update_file (expand_path ~dir ~f x, expand_str ~dir ~f y)
in | Rename (x, y) ->
Io.copy_channels ic oc); Rename (expand_path ~dir ~f x, expand_path ~dir ~f y)
return () | Remove_tree x ->
| Create_file fn -> Remove_tree (expand_path ~dir ~f x)
let fn = Path.to_string fn in
if Sys.file_exists fn then Sys.remove fn;
Unix.close (Unix.openfile fn [O_CREAT; O_TRUNC; O_WRONLY] 0o666);
return ()
| Copy (src, dst) ->
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
return ()
| Symlink (src, dst) ->
if Sys.win32 then
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
else begin
let src =
if Path.is_root dst then
Path.to_string src
else
Path.reach ~from:(Path.parent dst) src
in
let dst = Path.to_string dst in
match Unix.readlink dst with
| target ->
if target <> src then begin
Unix.unlink dst;
Unix.symlink src dst
end
| exception _ ->
Unix.symlink src dst
end;
return ()
| Copy_and_add_line_directive (src, dst) ->
Io.with_file_in (Path.to_string src) ~f:(fun ic ->
Io.with_file_out (Path.to_string dst) ~f:(fun oc ->
let fn = Path.drop_build_context src in
Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
Io.copy_channels ic oc));
return ()
| System cmd ->
let path, arg =
Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
in
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
| Bash cmd ->
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
(Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
| Update_file (fn, s) ->
let fn = Path.to_string fn in
if Sys.file_exists fn && Io.read_file fn = s then
()
else
Io.write_file fn s;
return ()
| Rename (src, dst) ->
Unix.rename (Path.to_string src) (Path.to_string dst);
return ()
| Remove_tree path ->
Path.rm_rf path;
return ()
and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
let fn = Path.to_string fn in
let oc = Io.open_out fn in
let out = Some (fn, oc) in
let stdout_to, stderr_to =
match outputs with
| Stdout -> (out, stderr_to)
| Stderr -> (stdout_to, out)
| Outputs -> (out, out)
in
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>| fun () ->
close_out oc
and exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
match l with
| [] ->
Future.return ()
| [t] ->
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
| t :: rest ->
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () ->
exec_list rest ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
end end
type t = open Future
{ context : Context.t option
; action : Mini_shexp.t
}
let sexp_of_t { context; action } = let get_std_output : _ -> Future.std_output_to = function
let fields : Sexp.t list = | None -> Terminal
[ List [ Atom "action" ; Mini_shexp.sexp_of_t action ] | Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
]
in
let fields =
match context with
| None -> fields
| Some { name; _ } -> List [ Atom "context"; Atom name ] :: fields
in
Sexp.List fields
let exec ~targets { action; context } = let run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args =
let stdout_to = get_std_output stdout_to in
let stderr_to = get_std_output stderr_to in
let env = Context.extend_env ~vars:env_extra ~env in
Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to ~stderr_to ~purpose
(Path.reach_for_running ~from:dir prog) args
let rec exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
match t with
| Run (prog, args) ->
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to prog args
| Chdir (dir, t) ->
exec t ~purpose ~env ~env_extra ~stdout_to ~stderr_to ~dir
| Setenv (var, value, t) ->
exec t ~purpose ~dir ~env ~stdout_to ~stderr_to
~env_extra:(Env_var_map.add env_extra ~key:var ~data:value)
| Redirect (outputs, fn, t) ->
redirect ~purpose outputs fn t ~dir ~env ~env_extra ~stdout_to ~stderr_to
| Ignore (outputs, t) ->
redirect ~purpose outputs Config.dev_null t ~dir ~env ~env_extra ~stdout_to ~stderr_to
| Progn l ->
exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
| Echo str ->
return
(match stdout_to with
| None -> print_string str; flush stdout
| Some (_, oc) -> output_string oc str)
| Cat fn ->
Io.with_file_in (Path.to_string fn) ~f:(fun ic ->
let oc =
match stdout_to with
| None -> stdout
| Some (_, oc) -> oc
in
Io.copy_channels ic oc);
return ()
| Create_file fn ->
let fn = Path.to_string fn in
if Sys.file_exists fn then Sys.remove fn;
Unix.close (Unix.openfile fn [O_CREAT; O_TRUNC; O_WRONLY] 0o666);
return ()
| Copy (src, dst) ->
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
return ()
| Symlink (src, dst) ->
if Sys.win32 then
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
else begin
let src =
if Path.is_root dst then
Path.to_string src
else
Path.reach ~from:(Path.parent dst) src
in
let dst = Path.to_string dst in
match Unix.readlink dst with
| target ->
if target <> src then begin
Unix.unlink dst;
Unix.symlink src dst
end
| exception _ ->
Unix.symlink src dst
end;
return ()
| Copy_and_add_line_directive (src, dst) ->
Io.with_file_in (Path.to_string src) ~f:(fun ic ->
Io.with_file_out (Path.to_string dst) ~f:(fun oc ->
let fn = Path.drop_build_context src in
Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
Io.copy_channels ic oc));
return ()
| System cmd ->
let path, arg =
Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
in
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
| Bash cmd ->
run ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
(Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
| Update_file (fn, s) ->
let fn = Path.to_string fn in
if Sys.file_exists fn && Io.read_file fn = s then
()
else
Io.write_file fn s;
return ()
| Rename (src, dst) ->
Unix.rename (Path.to_string src) (Path.to_string dst);
return ()
| Remove_tree path ->
Path.rm_rf path;
return ()
and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
let fn = Path.to_string fn in
let oc = Io.open_out fn in
let out = Some (fn, oc) in
let stdout_to, stderr_to =
match outputs with
| Stdout -> (out, stderr_to)
| Stderr -> (stdout_to, out)
| Outputs -> (out, out)
in
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>| fun () ->
close_out oc
and exec_list l ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
match l with
| [] ->
Future.return ()
| [t] ->
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
| t :: rest ->
exec t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to >>= fun () ->
exec_list rest ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to
let exec ~targets ?context t =
let env = let env =
match context with match (context : Context.t option) with
| None -> Lazy.force Context.initial_env | None -> Lazy.force Context.initial_env
| Some c -> c.env | Some c -> c.env
in in
let targets = Path.Set.elements targets in let targets = Path.Set.elements targets in
let purpose = Future.Build_job targets in let purpose = Future.Build_job targets in
Mini_shexp.exec action ~purpose ~dir:Path.root ~env ~env_extra:Env_var_map.empty exec t ~purpose ~dir:Path.root ~env ~env_extra:Env_var_map.empty
~stdout_to:None ~stderr_to:None ~stdout_to:None ~stderr_to:None
let sandbox t ~sandboxed ~deps ~targets = let sandbox t ~sandboxed ~deps ~targets =
let action = Ast.Progn
let module M = Mini_shexp.Ast in [ Ast.Progn (List.filter_map deps ~f:(fun path ->
M.Progn if Path.is_local path then
[ M.Progn (List.filter_map deps ~f:(fun path -> Some (Ast.Symlink (path, sandboxed path))
if Path.is_local path then else
Some (M.Symlink (path, sandboxed path)) None))
else ; Ast.map t ~f1:(fun x -> x) ~f2:sandboxed
None)) ; Ast.Progn (List.filter_map targets ~f:(fun path ->
; M.map t.action ~f1:(fun x -> x) ~f2:sandboxed if Path.is_local path then
; M.Progn (List.filter_map targets ~f:(fun path -> Some (Ast.Rename (sandboxed path, path))
if Path.is_local path then else
Some (M.Rename (sandboxed path, path)) None))
else ]
None))
]
in
{ t with action }
type for_hash = string option * Mini_shexp.t
let for_hash { context; action } =
(Option.map context ~f:(fun c -> c.name), action)

98
src/action.mli
View File

@ -6,62 +6,55 @@ type var_expansion =
| Paths of Path.t list | Paths of Path.t list
| Str of string | Str of string
module Mini_shexp : sig module Ast : sig
module Ast : sig type outputs =
type outputs = | Stdout
| Stdout | Stderr
| Stderr | Outputs (** Both Stdout and Stderr *)
| Outputs (** Both Stdout and Stderr *)
type ('a, 'path) t = type ('a, 'path) t =
| Run of 'path * 'a list | Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t | Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t | Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t | Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t | Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list | Progn of ('a, 'path) t list
| Echo of 'a | Echo of 'a
| Create_file of 'path | Create_file of 'path
| Cat of 'path | Cat of 'path
| Copy of 'path * 'path | Copy of 'path * 'path
| Symlink of 'path * 'path | Symlink of 'path * 'path
| Copy_and_add_line_directive of 'path * 'path | Copy_and_add_line_directive of 'path * 'path
| System of 'a | System of 'a
| Bash of 'a | Bash of 'a
| Update_file of 'path * 'a | Update_file of 'path * 'a
| Rename of 'path * 'path | Rename of 'path * 'path
| Remove_tree of 'path | Remove_tree of 'path
val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t
val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
end
type t = (string, Path.t) Ast.t val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t
val t : t Sexp.Of_sexp.t val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
(** Return the list of files under an [Update_file] *)
val updated_files : t -> Path.Set.t
(** Return the list of directories the action chdirs to *)
val chdirs : t -> Path.Set.t
module Unexpanded : sig
type desc = t
type t = (String_with_vars.t, String_with_vars.t) Ast.t
val t : t Sexp.Of_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
val fold_vars : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a
val expand : Context.t -> Path.t -> t -> f:(string -> var_expansion) -> desc
end with type desc := t
end end
type t = type t = (string, Path.t) Ast.t
{ context : Context.t option val t : t Sexp.Of_sexp.t
; action : Mini_shexp.t
}
val sexp_of_t : t Sexp.To_sexp.t val sexp_of_t : t Sexp.To_sexp.t
val exec : targets:Path.Set.t -> t -> unit Future.t
(** Return the list of files under an [Update_file] *)
val updated_files : t -> Path.Set.t
(** Return the list of directories the action chdirs to *)
val chdirs : t -> Path.Set.t
module Unexpanded : sig
type desc = t
type t = (String_with_vars.t, String_with_vars.t) Ast.t
val t : t Sexp.Of_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
val fold_vars : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a
val expand : Context.t -> Path.t -> t -> f:(string -> var_expansion) -> desc
end with type desc := t
val exec : targets:Path.Set.t -> ?context:Context.t -> t -> unit Future.t
(* Return a sandboxed version of an action *) (* Return a sandboxed version of an action *)
val sandbox val sandbox
@ -70,6 +63,3 @@ val sandbox
-> deps:Path.t list -> deps:Path.t list
-> targets:Path.t list -> targets:Path.t list
-> t -> t
type for_hash
val for_hash : t -> for_hash

33
src/action_intf.ml Normal file
View File

@ -0,0 +1,33 @@
module Outputs = struct
type t =
| Stdout
| Stderr
| Outputs (** Both Stdout and Stderr *)
end
module type Ast = sig
type path
type string
type t =
| Run of path * string list
| Chdir of path * t
| Setenv of string * string * t
| Redirect of Outputs.t * path * t
| Ignore of Outputs.t * t
| Progn of t list
| Echo of string
| Create_file of path
| Cat of path
| Copy of path * path
| Symlink of path * path
| Copy_and_add_line_directive of path * path
| System of string
| Bash of string
| Update_file of path * string
| Rename of path * path
| Remove_tree of path
| Try_run of path * string list * t
| Located_error of path * int * int * int * string
end

77
src/build.ml
View File

@ -179,7 +179,7 @@ let get_prog (prog : _ Prog_spec.t) =
| Dep p -> path p >>> arr (fun _ -> p) | Dep p -> path p >>> arr (fun _ -> p)
| Dyn f -> arr f >>> dyn_paths (arr (fun x -> [x])) | Dyn f -> arr f >>> dyn_paths (arr (fun x -> [x]))
let prog_and_args ~dir prog args = let prog_and_args ?(dir=Path.root) prog args =
Paths (Arg_spec.add_deps args Pset.empty) Paths (Arg_spec.add_deps args Pset.empty)
>>> >>>
(get_prog prog &&& (get_prog prog &&&
@ -201,83 +201,50 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[])
>>> >>>
Targets targets Targets targets
>>^ (fun (prog, args) -> >>^ (fun (prog, args) ->
let action : Action.Mini_shexp.t = Run (prog, args) in let action : Action.t = Run (prog, args) in
let action = let action =
match stdout_to with match stdout_to with
| None -> action | None -> action
| Some path -> Redirect (Stdout, path, action) | Some path -> Redirect (Stdout, path, action)
in in
{ Action. Action.Ast.Chdir (dir, action))
context = Some context
; action = Chdir (dir, action)
})
let action ~context ?(dir=context.Context.build_dir) ~targets action = let action ?dir ~targets action =
Targets targets
>>^ fun () ->
{ Action. context = Some context; action = Chdir (dir, action) }
let action_dyn ~context ?(dir=context.Context.build_dir) ~targets () =
Targets targets
>>^ fun action ->
{ Action. context = Some context; action = Chdir (dir, action) }
let action_context_independent ?dir ~targets action =
let action : Action.Mini_shexp.t =
match dir with
| None -> action
| Some dir -> Chdir (dir, action)
in
Targets targets Targets targets
>>^ fun _ -> >>^ fun _ ->
{ Action. context = None; action } match dir with
| None -> action
| Some dir -> Action.Ast.Chdir (dir, action)
let action_dyn ?dir ~targets () =
Targets targets
>>^ fun action ->
match dir with
| None -> action
| Some dir -> Action.Ast.Chdir (dir, action)
let update_file fn s = let update_file fn s =
action_context_independent ~targets:[fn] (Update_file (fn, s)) action ~targets:[fn] (Update_file (fn, s))
let update_file_dyn fn = let update_file_dyn fn =
Targets [fn] Targets [fn]
>>^ fun s -> >>^ fun s ->
{ Action. Action.Ast.Update_file (fn, s)
context = None
; action = Update_file (fn, s)
}
let copy ~src ~dst = let copy ~src ~dst =
path src >>> path src >>>
action_context_independent ~targets:[dst] (Copy (src, dst)) action ~targets:[dst] (Copy (src, dst))
let symlink ~src ~dst = let symlink ~src ~dst =
path src >>> path src >>>
action_context_independent ~targets:[dst] (Symlink (src, dst)) action ~targets:[dst] (Symlink (src, dst))
let create_file fn = let create_file fn =
action_context_independent ~targets:[fn] (Create_file fn) action ~targets:[fn] (Create_file fn)
let remove_tree dir = let remove_tree dir =
arr (fun _ -> arr (fun _ -> Action.Ast.Remove_tree dir)
{ Action. context = None; action = Remove_tree dir })
let progn ts = let progn ts =
all ts >>^ fun (actions : Action.t list) -> all ts >>^ fun actions ->
let rec loop context acc actions = Action.Ast.Progn actions
match actions with
| [] ->
{ Action.
context
; action = Progn (List.rev acc)
}
| { Action. context = context'; action } :: rest ->
let context =
match context, context' with
| None, c | c, None -> c
| Some c1, Some c2 when c1.name = c2.name -> context
| _ -> raise Exit
in
loop context (action :: acc) rest
in
try
loop None [] actions
with Exit ->
Sexp.code_error "Build.progn"
[ "actions", Sexp.To_sexp.list Action.sexp_of_t actions ]

20
src/build.mli
View File

@ -80,7 +80,7 @@ end
val run val run
: context:Context.t : context:Context.t
-> ?dir:Path.t (* default: context.build_dir *) -> ?dir:Path.t (* default: [context.build_dir] *)
-> ?stdout_to:Path.t -> ?stdout_to:Path.t
-> ?extra_targets:Path.t list -> ?extra_targets:Path.t list
-> 'a Prog_spec.t -> 'a Prog_spec.t
@ -88,24 +88,16 @@ val run
-> ('a, Action.t) t -> ('a, Action.t) t
val action val action
: context:Context.t : ?dir:Path.t
-> ?dir:Path.t (* default: context.build_dir *)
-> targets:Path.t list -> targets:Path.t list
-> Action.Mini_shexp.t -> Action.t
-> (unit, Action.t) t -> (_, Action.t) t
val action_dyn val action_dyn
: context:Context.t : ?dir:Path.t
-> ?dir:Path.t (* default: context.build_dir *)
-> targets:Path.t list -> targets:Path.t list
-> unit -> unit
-> (Action.Mini_shexp.t, Action.t) t -> (Action.t, Action.t) t
val action_context_independent
: ?dir:Path.t (* default: Path.root *)
-> targets:Path.t list
-> Action.Mini_shexp.t
-> (unit, Action.t) t
(** Create a file with the given contents. Do not ovewrite the file if (** Create a file with the given contents. Do not ovewrite the file if
it hasn't changed. *) it hasn't changed. *)

8
src/build_interpret.ml
View File

@ -144,13 +144,15 @@ let targets =
module Rule = struct module Rule = struct
type t = type t =
{ build : (unit, Action.t) Build.t { context : Context.t option
; build : (unit, Action.t) Build.t
; targets : Target.t list ; targets : Target.t list
; sandbox : bool ; sandbox : bool
} }
let make ?(sandbox=false) build = let make ?(sandbox=false) ?context build =
{ build { context
; build
; targets = targets build ; targets = targets build
; sandbox ; sandbox
} }

5
src/build_interpret.mli
View File

@ -11,12 +11,13 @@ end
module Rule : sig module Rule : sig
type t = type t =
{ build : (unit, Action.t) Build.t { context : Context.t option
; build : (unit, Action.t) Build.t
; targets : Target.t list ; targets : Target.t list
; sandbox : bool ; sandbox : bool
} }
val make : ?sandbox:bool -> (unit, Action.t) Build.t -> t val make : ?sandbox:bool -> ?context:Context.t -> (unit, Action.t) Build.t -> t
end end
module Static_deps : sig module Static_deps : sig

22
src/build_system.ml
View File

@ -63,6 +63,7 @@ module Internal_rule = struct
; rule_deps : Pset.t ; rule_deps : Pset.t
; static_deps : Pset.t ; static_deps : Pset.t
; targets : Pset.t ; targets : Pset.t
; context : Context.t option
; build : (unit, Action.t) Build.t ; build : (unit, Action.t) Build.t
; mutable exec : Exec_status.t ; mutable exec : Exec_status.t
} }
@ -270,10 +271,7 @@ module Build_exec = struct
| Store_vfile (Vspec.T (fn, kind)) -> | Store_vfile (Vspec.T (fn, kind)) ->
let file = get_file bs fn (Sexp_file kind) in let file = get_file bs fn (Sexp_file kind) in
file.data <- Some x; file.data <- Some x;
{ Action. Update_file (fn, vfile_to_string kind fn x)
context = None
; action = Update_file (fn, vfile_to_string kind fn x)
}
| Compose (a, b) -> | Compose (a, b) ->
exec dyn_deps a x |> exec dyn_deps b exec dyn_deps a x |> exec dyn_deps b
| First t -> | First t ->
@ -394,7 +392,7 @@ let make_local_parent_dirs t paths ~map_path =
let sandbox_dir = Path.of_string "_build/.sandbox" let sandbox_dir = Path.of_string "_build/.sandbox"
let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
let { Pre_rule. build; targets = target_specs; sandbox } = pre_rule in let { Pre_rule. context; build; targets = target_specs; sandbox } = pre_rule in
let targets = Target.paths target_specs in let targets = Target.paths target_specs in
let { Build_interpret.Static_deps. let { Build_interpret.Static_deps.
rule_deps rule_deps
@ -420,7 +418,12 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
let all_deps_as_list = Pset.elements all_deps in let all_deps_as_list = Pset.elements all_deps in
let targets_as_list = Pset.elements targets in let targets_as_list = Pset.elements targets in
let hash = let hash =
let trace = (all_deps_as_list, targets_as_list, Action.for_hash action) in let trace =
(all_deps_as_list,
targets_as_list,
Option.map context ~f:(fun c -> c.name),
action)
in
Digest.string (Marshal.to_string trace []) Digest.string (Marshal.to_string trace [])
in in
let sandbox_dir = let sandbox_dir =
@ -465,7 +468,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
(* Do not remove files that are just updated, otherwise this would break incremental (* Do not remove files that are just updated, otherwise this would break incremental
compilation *) compilation *)
let targets_to_remove = let targets_to_remove =
Pset.diff targets (Action.Mini_shexp.updated_files action.action) Pset.diff targets (Action.updated_files action)
in in
Pset.iter targets_to_remove ~f:Path.unlink_no_err; Pset.iter targets_to_remove ~f:Path.unlink_no_err;
pending_targets := Pset.union targets_to_remove !pending_targets; pending_targets := Pset.union targets_to_remove !pending_targets;
@ -488,7 +491,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
| None -> | None ->
action action
in in
make_local_dirs t (Action.Mini_shexp.chdirs action.action); make_local_dirs t (Action.chdirs action);
Action.exec ~targets action >>| fun () -> Action.exec ~targets action >>| fun () ->
Option.iter sandbox_dir ~f:Path.rm_rf; Option.iter sandbox_dir ~f:Path.rm_rf;
(* All went well, these targets are no longer pending *) (* All went well, these targets are no longer pending *)
@ -504,6 +507,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
; rule_deps ; rule_deps
; targets ; targets
; build ; build
; context
; exec = Not_started { eval_rule; exec_rule } ; exec = Not_started { eval_rule; exec_rule }
} }
in in
@ -723,6 +727,7 @@ module Rule = struct
{ id : Id.t { id : Id.t
; deps : Path.Set.t ; deps : Path.Set.t
; targets : Path.Set.t ; targets : Path.Set.t
; context : Context.t option
; action : Action.t ; action : Action.t
} }
@ -767,6 +772,7 @@ let build_rules t ?(recursive=false) targets =
id = ir.id id = ir.id
; deps = Pset.union ir.static_deps dyn_deps ; deps = Pset.union ir.static_deps dyn_deps
; targets = ir.targets ; targets = ir.targets
; context = ir.context
; action = action ; action = action
} }
in in

1
src/build_system.mli
View File

@ -49,6 +49,7 @@ module Rule : sig
{ id : Id.t { id : Id.t
; deps : Path.Set.t ; deps : Path.Set.t
; targets : Path.Set.t ; targets : Path.Set.t
; context : Context.t option
; action : Action.t ; action : Action.t
} }
end end

3
src/gen_rules.ml
View File

@ -495,7 +495,8 @@ module Gen(P : Params) = struct
let action = let action =
match alias_conf.action with match alias_conf.action with
| None -> Sexp.Atom "none" | None -> Sexp.Atom "none"
| Some a -> List [Atom "some" ; Action.Mini_shexp.Unexpanded.sexp_of_t a] in | Some a -> List [Atom "some" ; Action.Unexpanded.sexp_of_t a]
in
Sexp.List [deps ; action] Sexp.List [deps ; action]
|> Sexp.to_string |> Sexp.to_string
|> Digest.string |> Digest.string

12
src/jbuild_types.ml
View File

@ -225,13 +225,13 @@ module Preprocess = struct
type pps = { pps : Pp.t list; flags : string list } type pps = { pps : Pp.t list; flags : string list }
type t = type t =
| No_preprocessing | No_preprocessing
| Action of Action.Mini_shexp.Unexpanded.t | Action of Action.Unexpanded.t
| Pps of pps | Pps of pps
let t = let t =
sum sum
[ cstr "no_preprocessing" nil No_preprocessing [ cstr "no_preprocessing" nil No_preprocessing
; cstr "action" (Action.Mini_shexp.Unexpanded.t @> nil) (fun x -> Action x) ; cstr "action" (Action.Unexpanded.t @> nil) (fun x -> Action x)
; cstr "pps" (list Pp_or_flags.t @> nil) (fun l -> ; cstr "pps" (list Pp_or_flags.t @> nil) (fun l ->
let pps, flags = Pp_or_flags.split l in let pps, flags = Pp_or_flags.split l in
Pps { pps; flags }) Pps { pps; flags })
@ -689,14 +689,14 @@ module Rule = struct
type t = type t =
{ targets : string list (** List of files in the current directory *) { targets : string list (** List of files in the current directory *)
; deps : Dep_conf.t list ; deps : Dep_conf.t list
; action : Action.Mini_shexp.Unexpanded.t ; action : Action.Unexpanded.t
} }
let v1 = let v1 =
record record
(field "targets" (list file_in_current_dir) >>= fun targets -> (field "targets" (list file_in_current_dir) >>= fun targets ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
field "action" Action.Mini_shexp.Unexpanded.t >>= fun action -> field "action" Action.Unexpanded.t >>= fun action ->
return { targets; deps; action }) return { targets; deps; action })
let ocamllex_v1 names = let ocamllex_v1 names =
@ -807,7 +807,7 @@ module Alias_conf = struct
type t = type t =
{ name : string { name : string
; deps : Dep_conf.t list ; deps : Dep_conf.t list
; action : Action.Mini_shexp.Unexpanded.t option ; action : Action.Unexpanded.t option
; package : Package.t option ; package : Package.t option
} }
@ -816,7 +816,7 @@ module Alias_conf = struct
(field "name" string >>= fun name -> (field "name" string >>= fun name ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
field_o "package" (Pkgs.package pkgs) >>= fun package -> field_o "package" (Pkgs.package pkgs) >>= fun package ->
field_o "action" Action.Mini_shexp.Unexpanded.t >>= fun action -> field_o "action" Action.Unexpanded.t >>= fun action ->
return return
{ name { name
; deps ; deps

14
src/super_context.ml
View File

@ -54,6 +54,7 @@ type t =
; ppx_dir : Path.t ; ppx_dir : Path.t
; ppx_drivers : (string, Path.t) Hashtbl.t ; ppx_drivers : (string, Path.t) Hashtbl.t
; external_dirs : (Path.t, External_dir.t) Hashtbl.t ; external_dirs : (Path.t, External_dir.t) Hashtbl.t
; chdir : (Action.t, Action.t) Build.t
} }
let context t = t.context let context t = t.context
@ -199,10 +200,15 @@ let create
; ppx_drivers = Hashtbl.create 32 ; ppx_drivers = Hashtbl.create 32
; ppx_dir = Path.relative context.build_dir ".ppx" ; ppx_dir = Path.relative context.build_dir ".ppx"
; external_dirs = Hashtbl.create 1024 ; external_dirs = Hashtbl.create 1024
; chdir = Build.arr (fun (action : Action.t) ->
match action with
| Chdir _ -> action
| _ -> Chdir (context.build_dir, action))
} }
let add_rule t ?sandbox build = let add_rule t ?sandbox build =
let rule = Build_interpret.Rule.make ?sandbox build in let build = Build.O.(>>>) build t.chdir in
let rule = Build_interpret.Rule.make ?sandbox ~context:t.context build in
t.rules <- rule :: t.rules; t.rules <- rule :: t.rules;
t.known_targets_by_src_dir_so_far <- t.known_targets_by_src_dir_so_far <-
List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far
@ -303,7 +309,7 @@ module Libs = struct
add_rule t add_rule t
(Build.path src (Build.path src
>>> >>>
Build.action_context_independent ~targets:[dst] Build.action ~targets:[dst]
(Copy_and_add_line_directive (src, dst)))) (Copy_and_add_line_directive (src, dst))))
let real_requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps = let real_requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
@ -448,7 +454,7 @@ end
module Action = struct module Action = struct
open Build.O open Build.O
module U = Action.Mini_shexp.Unexpanded module U = Action.Unexpanded
type resolved_forms = type resolved_forms =
{ (* Mapping from ${...} forms to their resolutions *) { (* Mapping from ${...} forms to their resolutions *)
@ -569,7 +575,7 @@ module Action = struct
U.expand sctx.context dir t U.expand sctx.context dir t
~f:(expand_var sctx ~artifacts ~targets ~deps)) ~f:(expand_var sctx ~artifacts ~targets ~deps))
>>> >>>
Build.action_dyn () ~context:sctx.context ~dir ~targets Build.action_dyn () ~dir ~targets
in in
match forms.failures with match forms.failures with
| [] -> build | [] -> build

2
src/super_context.mli
View File

@ -126,7 +126,7 @@ end
module Action : sig module Action : sig
val run val run
: t : t
-> Action.Mini_shexp.Unexpanded.t -> Action.Unexpanded.t
-> dir:Path.t -> dir:Path.t
-> dep_kind:Build.lib_dep_kind -> dep_kind:Build.lib_dep_kind
-> targets:Path.t list -> targets:Path.t list