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 ->
Path.Set.iter rule.deps ~f:(fun 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
List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
let sexp =
@ -594,10 +594,10 @@ let rules =
List.concat
[ [ "deps" , paths rule.deps
; "targets", paths rule.targets ]
; (match rule.action.context with
; (match rule.context with
| None -> []
| Some c -> ["context", Atom c.name])
; [ "action" , Action.Mini_shexp.sexp_of_t rule.action.action ]
; [ "action" , Action.sexp_of_t rule.action ]
])
in
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`
(context ((switch 4.02.3)))
(context ((switch 4.03.0)))
(context ((switch 4.04.0)))
(context ((switch 4.04.1)))
(context ((switch 4.05.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:" "
|> resolve
module Mini_shexp = struct
module Ast = struct
type outputs =
| Stdout
| Stderr
| Outputs (* Both Stdout and Stderr *)
module Ast = struct
type outputs =
| Stdout
| Stderr
| Outputs (* Both Stdout and Stderr *)
let string_of_outputs = function
| Stdout -> "stdout"
| Stderr -> "stderr"
| Outputs -> "outputs"
let string_of_outputs = function
| Stdout -> "stdout"
| Stderr -> "stderr"
| Outputs -> "outputs"
type ('a, 'path) t =
| Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list
| Echo of 'a
| 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 'a
| Bash of 'a
| Update_file of 'path * 'a
| Rename of 'path * 'path
| Remove_tree of 'path
type ('a, 'path) t =
| Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list
| Echo of 'a
| 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 'a
| Bash of 'a
| Update_file of 'path * 'a
| Rename of 'path * 'path
| Remove_tree of 'path
let rec t a p sexp =
sum
[ 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 "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-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 "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-outputs" (t a p @> nil) (fun t -> Ignore (Outputs, t))
; cstr_rest "progn" nil (t a p) (fun l -> Progn l)
; cstr "echo" (a @> nil) (fun x -> Echo x)
; cstr "cat" (p @> nil) (fun x -> Cat x)
; cstr "create-file" (p @> nil) (fun x -> Create_file x)
; cstr "copy" (p @> p @> nil) (fun src dst -> Copy (src, dst))
let rec t a p sexp =
sum
[ 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 "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-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 "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-outputs" (t a p @> nil) (fun t -> Ignore (Outputs, t))
; cstr_rest "progn" nil (t a p) (fun l -> Progn l)
; cstr "echo" (a @> nil) (fun x -> Echo x)
; cstr "cat" (p @> nil) (fun x -> Cat x)
; cstr "create-file" (p @> nil) (fun x -> Create_file x)
; 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 *)
; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
*)
; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst))
; cstr "system" (a @> nil) (fun cmd -> System cmd)
; cstr "bash" (a @> nil) (fun cmd -> Bash cmd)
]
sexp
(* 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 "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst))
; cstr "system" (a @> nil) (fun cmd -> System cmd)
; cstr "bash" (a @> nil) (fun cmd -> Bash cmd)
]
sexp
let rec sexp_of_t f g : _ -> Sexp.t = function
| 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]
| Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r]
| Redirect (outputs, fn, r) ->
List [ Atom (sprintf "with-%s-to" (string_of_outputs outputs))
; g fn
; sexp_of_t f g r
]
| Ignore (outputs, r) ->
List [ Atom (sprintf "ignore-%s" (string_of_outputs outputs))
; sexp_of_t f g r
]
| Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
| Echo x -> List [Atom "echo"; f x]
| Cat x -> List [Atom "cat"; g x]
| Create_file x -> List [Atom "create-file"; g x]
| Copy (x, y) ->
List [Atom "copy"; g x; g y]
| Symlink (x, y) ->
List [Atom "symlink"; g x; g y]
| Copy_and_add_line_directive (x, y) ->
List [Atom "copy-and-add-line-directive"; g x; g y]
| System x -> List [Atom "system"; f x]
| Bash x -> List [Atom "bash"; f x]
| Update_file (x, y) -> List [Atom "update-file"; g x; f y]
| Rename (x, y) -> List [Atom "rename"; g x; g y]
| Remove_tree x -> List [Atom "remove-tree"; g x]
let rec sexp_of_t f g : _ -> Sexp.t = function
| 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]
| Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r]
| Redirect (outputs, fn, r) ->
List [ Atom (sprintf "with-%s-to" (string_of_outputs outputs))
; g fn
; sexp_of_t f g r
]
| Ignore (outputs, r) ->
List [ Atom (sprintf "ignore-%s" (string_of_outputs outputs))
; sexp_of_t f g r
]
| Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
| Echo x -> List [Atom "echo"; f x]
| Cat x -> List [Atom "cat"; g x]
| Create_file x -> List [Atom "create-file"; g x]
| Copy (x, y) ->
List [Atom "copy"; g x; g y]
| Symlink (x, y) ->
List [Atom "symlink"; g x; g y]
| Copy_and_add_line_directive (x, y) ->
List [Atom "copy-and-add-line-directive"; g x; g y]
| System x -> List [Atom "system"; f x]
| Bash x -> List [Atom "bash"; f x]
| Update_file (x, y) -> List [Atom "update-file"; g x; f y]
| Rename (x, y) -> List [Atom "rename"; g x; g y]
| Remove_tree x -> List [Atom "remove-tree"; g x]
let rec fold t ~init:acc ~f =
match t with
| Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
| Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
| Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
| Redirect (_, fn, t) -> fold t ~init:(f acc fn) ~f
| Ignore (_, t) -> fold t ~init:acc ~f
| Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
| Echo x -> f acc x
| Cat x -> f acc x
| Create_file x -> f acc x
| Copy (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
| System x -> f acc x
| Bash x -> f acc x
| Update_file (x, y) -> f (f acc x) y
| Rename (x, y) -> f (f acc x) y
| Remove_tree x -> f acc x
let rec fold t ~init:acc ~f =
match t with
| Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
| Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
| Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
| Redirect (_, fn, t) -> fold t ~init:(f acc fn) ~f
| Ignore (_, t) -> fold t ~init:acc ~f
| Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
| Echo x -> f acc x
| Cat x -> f acc x
| Create_file x -> f acc x
| Copy (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
| System x -> f acc x
| Bash x -> f acc x
| Update_file (x, y) -> f (f acc x) y
| Rename (x, y) -> f (f acc x) y
| Remove_tree x -> f acc x
let fold_one_step t ~init:acc ~f =
match t with
| Chdir (_, t)
| Setenv (_, _, t)
| Redirect (_, _, t)
| Ignore (_, t) -> f acc t
| Progn l -> List.fold_left l ~init:acc ~f
| Run _
| Echo _
| Cat _
| Create_file _
| Copy _
| Symlink _
| Copy_and_add_line_directive _
| System _
| Bash _
| Update_file _
| Rename _
| Remove_tree _ -> acc
let fold_one_step t ~init:acc ~f =
match t with
| Chdir (_, t)
| Setenv (_, _, t)
| Redirect (_, _, t)
| Ignore (_, t) -> f acc t
| Progn l -> List.fold_left l ~init:acc ~f
| Run _
| Echo _
| Cat _
| Create_file _
| Copy _
| Symlink _
| Copy_and_add_line_directive _
| System _
| Bash _
| Update_file _
| Rename _
| Remove_tree _ -> acc
let rec map
: 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t
= 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 =
let rec map
: 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t
= fun t ~f1 ~f2 ->
match t with
| Run (prog, args) ->
Run (expand_prog ctx ~dir ~f prog,
List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
Run (f2 prog, List.map args ~f:f1)
| Chdir (fn, t) ->
let fn = expand_path ~dir ~f fn in
Chdir (fn, expand ctx fn t ~f)
Chdir (f2 fn, map t ~f1 ~f2)
| Setenv (var, value, t) ->
Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value,
expand ctx dir t ~f)
Setenv (f1 var, f1 value, map t ~f1 ~f2)
| 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, expand ctx dir t ~f)
| Progn l -> Progn (List.map l ~f:(fun t -> expand ctx dir t ~f))
| Echo x -> Echo (expand_str ~dir ~f x)
| Cat x -> Cat (expand_path ~dir ~f x)
| Create_file x -> Create_file (expand_path ~dir ~f x)
| Copy (x, y) ->
Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
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 (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 (expand_path ~dir ~f x, expand_path ~dir ~f y)
| System x -> System (expand_str ~dir ~f x)
| Bash x -> Bash (expand_str ~dir ~f x)
| Update_file (x, y) -> Update_file (expand_path ~dir ~f x, expand_str ~dir ~f y)
| Rename (x, y) ->
Rename (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Remove_tree x ->
Remove_tree (expand_path ~dir ~f x)
end
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
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
| None -> Terminal
| Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
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 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 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
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
| 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
Run (expand_prog ctx ~dir ~f prog,
List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
| Chdir (fn, t) ->
let fn = expand_path ~dir ~f fn in
Chdir (fn, expand ctx fn t ~f)
| 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)
Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value,
expand ctx dir t ~f)
| 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) ->
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
Ignore (outputs, expand ctx dir t ~f)
| Progn l -> Progn (List.map l ~f:(fun t -> expand ctx dir t ~f))
| Echo x -> Echo (expand_str ~dir ~f x)
| Cat x -> Cat (expand_path ~dir ~f x)
| Create_file x -> Create_file (expand_path ~dir ~f x)
| Copy (x, y) ->
Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Symlink (x, y) ->
Symlink (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Copy_and_add_line_directive (x, y) ->
Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y)
| System x -> System (expand_str ~dir ~f x)
| Bash x -> Bash (expand_str ~dir ~f x)
| Update_file (x, y) -> Update_file (expand_path ~dir ~f x, expand_str ~dir ~f y)
| Rename (x, y) ->
Rename (expand_path ~dir ~f x, expand_path ~dir ~f y)
| Remove_tree x ->
Remove_tree (expand_path ~dir ~f x)
end
type t =
{ context : Context.t option
; action : Mini_shexp.t
}
open Future
let sexp_of_t { context; action } =
let fields : Sexp.t list =
[ List [ Atom "action" ; Mini_shexp.sexp_of_t action ]
]
in
let fields =
match context with
| None -> fields
| Some { name; _ } -> List [ Atom "context"; Atom name ] :: fields
in
Sexp.List fields
let get_std_output : _ -> Future.std_output_to = function
| None -> Terminal
| Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
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 =
match context with
match (context : Context.t option) with
| None -> Lazy.force Context.initial_env
| Some c -> c.env
in
let targets = Path.Set.elements 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
let sandbox t ~sandboxed ~deps ~targets =
let action =
let module M = Mini_shexp.Ast in
M.Progn
[ M.Progn (List.filter_map deps ~f:(fun path ->
if Path.is_local path then
Some (M.Symlink (path, sandboxed path))
else
None))
; M.map t.action ~f1:(fun x -> x) ~f2:sandboxed
; M.Progn (List.filter_map targets ~f:(fun path ->
if Path.is_local path then
Some (M.Rename (sandboxed path, path))
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)
Ast.Progn
[ Ast.Progn (List.filter_map deps ~f:(fun path ->
if Path.is_local path then
Some (Ast.Symlink (path, sandboxed path))
else
None))
; Ast.map t ~f1:(fun x -> x) ~f2:sandboxed
; Ast.Progn (List.filter_map targets ~f:(fun path ->
if Path.is_local path then
Some (Ast.Rename (sandboxed path, path))
else
None))
]

98
src/action.mli
View File

@ -6,62 +6,55 @@ type var_expansion =
| Paths of Path.t list
| Str of string
module Mini_shexp : sig
module Ast : sig
type outputs =
| Stdout
| Stderr
| Outputs (** Both Stdout and Stderr *)
module Ast : sig
type outputs =
| Stdout
| Stderr
| Outputs (** Both Stdout and Stderr *)
type ('a, 'path) t =
| Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list
| Echo of 'a
| 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 'a
| Bash of 'a
| Update_file of 'path * 'a
| Rename of 'path * '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 ('a, 'path) t =
| Run of 'path * 'a list
| Chdir of 'path * ('a, 'path) t
| Setenv of 'a * 'a * ('a, 'path) t
| Redirect of outputs * 'path * ('a, 'path) t
| Ignore of outputs * ('a, 'path) t
| Progn of ('a, 'path) t list
| Echo of 'a
| 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 'a
| Bash of 'a
| Update_file of 'path * 'a
| Rename of 'path * 'path
| Remove_tree of 'path
type t = (string, Path.t) Ast.t
val t : t Sexp.Of_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
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 =
{ context : Context.t option
; action : Mini_shexp.t
}
type t = (string, Path.t) Ast.t
val t : t Sexp.Of_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 *)
val sandbox
@ -70,6 +63,3 @@ val sandbox
-> deps:Path.t list
-> targets:Path.t list
-> 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)
| 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)
>>>
(get_prog prog &&&
@ -201,83 +201,50 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[])
>>>
Targets targets
>>^ (fun (prog, args) ->
let action : Action.Mini_shexp.t = Run (prog, args) in
let action : Action.t = Run (prog, args) in
let action =
match stdout_to with
| None -> action
| Some path -> Redirect (Stdout, path, action)
in
{ Action.
context = Some context
; action = Chdir (dir, action)
})
Action.Ast.Chdir (dir, action))
let action ~context ?(dir=context.Context.build_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
let action ?dir ~targets action =
Targets targets
>>^ 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 =
action_context_independent ~targets:[fn] (Update_file (fn, s))
action ~targets:[fn] (Update_file (fn, s))
let update_file_dyn fn =
Targets [fn]
>>^ fun s ->
{ Action.
context = None
; action = Update_file (fn, s)
}
Action.Ast.Update_file (fn, s)
let copy ~src ~dst =
path src >>>
action_context_independent ~targets:[dst] (Copy (src, dst))
action ~targets:[dst] (Copy (src, dst))
let symlink ~src ~dst =
path src >>>
action_context_independent ~targets:[dst] (Symlink (src, dst))
action ~targets:[dst] (Symlink (src, dst))
let create_file fn =
action_context_independent ~targets:[fn] (Create_file fn)
action ~targets:[fn] (Create_file fn)
let remove_tree dir =
arr (fun _ ->
{ Action. context = None; action = Remove_tree dir })
arr (fun _ -> Action.Ast.Remove_tree dir)
let progn ts =
all ts >>^ fun (actions : Action.t list) ->
let rec loop context acc 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 ]
all ts >>^ fun actions ->
Action.Ast.Progn actions

20
src/build.mli
View File

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

8
src/build_interpret.ml
View File

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

5
src/build_interpret.mli
View File

@ -11,12 +11,13 @@ end
module Rule : sig
type t =
{ build : (unit, Action.t) Build.t
{ context : Context.t option
; build : (unit, Action.t) Build.t
; targets : Target.t list
; 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
module Static_deps : sig

22
src/build_system.ml
View File

@ -63,6 +63,7 @@ module Internal_rule = struct
; rule_deps : Pset.t
; static_deps : Pset.t
; targets : Pset.t
; context : Context.t option
; build : (unit, Action.t) Build.t
; mutable exec : Exec_status.t
}
@ -270,10 +271,7 @@ module Build_exec = struct
| Store_vfile (Vspec.T (fn, kind)) ->
let file = get_file bs fn (Sexp_file kind) in
file.data <- Some x;
{ Action.
context = None
; action = Update_file (fn, vfile_to_string kind fn x)
}
Update_file (fn, vfile_to_string kind fn x)
| Compose (a, b) ->
exec dyn_deps a x |> exec dyn_deps b
| First t ->
@ -394,7 +392,7 @@ let make_local_parent_dirs t paths ~map_path =
let sandbox_dir = Path.of_string "_build/.sandbox"
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 { Build_interpret.Static_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 targets_as_list = Pset.elements targets in
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 [])
in
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
compilation *)
let targets_to_remove =
Pset.diff targets (Action.Mini_shexp.updated_files action.action)
Pset.diff targets (Action.updated_files action)
in
Pset.iter targets_to_remove ~f:Path.unlink_no_err;
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 ->
action
in
make_local_dirs t (Action.Mini_shexp.chdirs action.action);
make_local_dirs t (Action.chdirs action);
Action.exec ~targets action >>| fun () ->
Option.iter sandbox_dir ~f:Path.rm_rf;
(* 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
; targets
; build
; context
; exec = Not_started { eval_rule; exec_rule }
}
in
@ -723,6 +727,7 @@ module Rule = struct
{ id : Id.t
; deps : Path.Set.t
; targets : Path.Set.t
; context : Context.t option
; action : Action.t
}
@ -767,6 +772,7 @@ let build_rules t ?(recursive=false) targets =
id = ir.id
; deps = Pset.union ir.static_deps dyn_deps
; targets = ir.targets
; context = ir.context
; action = action
}
in

1
src/build_system.mli
View File

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

3
src/gen_rules.ml
View File

@ -495,7 +495,8 @@ module Gen(P : Params) = struct
let action =
match alias_conf.action with
| 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.to_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 t =
| No_preprocessing
| Action of Action.Mini_shexp.Unexpanded.t
| Action of Action.Unexpanded.t
| Pps of pps
let t =
sum
[ 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 ->
let pps, flags = Pp_or_flags.split l in
Pps { pps; flags })
@ -689,14 +689,14 @@ module Rule = struct
type t =
{ targets : string list (** List of files in the current directory *)
; deps : Dep_conf.t list
; action : Action.Mini_shexp.Unexpanded.t
; action : Action.Unexpanded.t
}
let v1 =
record
(field "targets" (list file_in_current_dir) >>= fun targets ->
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 })
let ocamllex_v1 names =
@ -807,7 +807,7 @@ module Alias_conf = struct
type t =
{ name : string
; deps : Dep_conf.t list
; action : Action.Mini_shexp.Unexpanded.t option
; action : Action.Unexpanded.t option
; package : Package.t option
}
@ -816,7 +816,7 @@ module Alias_conf = struct
(field "name" string >>= fun name ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
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
{ name
; deps

14
src/super_context.ml
View File

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

2
src/super_context.mli
View File

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