simplify
This commit is contained in:
parent
304e4d9a7a
commit
cd359538b0
41
src/build.ml
41
src/build.ml
|
@ -177,30 +177,23 @@ module Shexp = struct
|
||||||
let env = Context.extend_env ~vars:env_extra ~env in
|
let env = Context.extend_env ~vars:env_extra ~env in
|
||||||
Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args
|
Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args
|
||||||
|
|
||||||
let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f =
|
let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail =
|
||||||
match t with
|
match t with
|
||||||
| Run (prog, args) ->
|
| Run (prog, args) ->
|
||||||
let prog = f ~dir prog in
|
|
||||||
let args = List.map args ~f:(f ~dir) in
|
|
||||||
run ~dir ~env ~env_extra ~stdout_to ~tail prog args
|
run ~dir ~env ~env_extra ~stdout_to ~tail prog args
|
||||||
| Chdir (fn, t) ->
|
| Chdir (fn, t) ->
|
||||||
let fn = f ~dir fn in
|
exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn)
|
||||||
exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn) ~f
|
|
||||||
| Setenv (var, value, t) ->
|
| Setenv (var, value, t) ->
|
||||||
let var = f ~dir var in
|
exec t ~dir ~env ~stdout_to ~tail
|
||||||
let value = f ~dir value in
|
|
||||||
exec t ~dir ~env ~stdout_to ~tail ~f
|
|
||||||
~env_extra:(String_map.add env_extra ~key:var ~data:value)
|
~env_extra:(String_map.add env_extra ~key:var ~data:value)
|
||||||
| With_stdout_to (fn, t) ->
|
| With_stdout_to (fn, t) ->
|
||||||
let fn = f ~dir fn in
|
|
||||||
if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
|
if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
|
||||||
let fn = Path.to_string (Path.relative dir fn) in
|
let fn = Path.to_string (Path.relative dir fn) in
|
||||||
exec t ~dir ~env ~env_extra ~tail ~f
|
exec t ~dir ~env ~env_extra ~tail
|
||||||
~stdout_to:(Some (fn, open_out_bin fn))
|
~stdout_to:(Some (fn, open_out_bin fn))
|
||||||
| Progn l ->
|
| Progn l ->
|
||||||
exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f
|
exec_list l ~dir ~env ~env_extra ~stdout_to ~tail
|
||||||
| Echo str ->
|
| Echo str ->
|
||||||
let str = f ~dir str in
|
|
||||||
return
|
return
|
||||||
(match stdout_to with
|
(match stdout_to with
|
||||||
| None -> print_string str; flush stdout
|
| None -> print_string str; flush stdout
|
||||||
|
@ -208,7 +201,6 @@ module Shexp = struct
|
||||||
output_string oc str;
|
output_string oc str;
|
||||||
if tail then close_out oc)
|
if tail then close_out oc)
|
||||||
| Cat fn ->
|
| Cat fn ->
|
||||||
let fn = f ~dir fn in
|
|
||||||
let fn = Path.to_string (Path.relative dir fn) in
|
let fn = Path.to_string (Path.relative dir fn) in
|
||||||
with_file_in fn ~f:(fun ic ->
|
with_file_in fn ~f:(fun ic ->
|
||||||
match stdout_to with
|
match stdout_to with
|
||||||
|
@ -218,8 +210,8 @@ module Shexp = struct
|
||||||
if tail then close_out oc);
|
if tail then close_out oc);
|
||||||
return ()
|
return ()
|
||||||
| Copy_and_add_line_directive (src, dst) ->
|
| Copy_and_add_line_directive (src, dst) ->
|
||||||
let src = Path.relative dir (f ~dir src) in
|
let src = Path.relative dir src in
|
||||||
let dst = Path.relative dir (f ~dir dst) in
|
let dst = Path.relative dir dst in
|
||||||
with_file_in (Path.to_string src) ~f:(fun ic ->
|
with_file_in (Path.to_string src) ~f:(fun ic ->
|
||||||
with_file_out (Path.to_string dst) ~f:(fun oc ->
|
with_file_out (Path.to_string dst) ~f:(fun oc ->
|
||||||
let fn =
|
let fn =
|
||||||
|
@ -231,7 +223,6 @@ module Shexp = struct
|
||||||
copy_channels ic oc));
|
copy_channels ic oc));
|
||||||
return ()
|
return ()
|
||||||
| System cmd ->
|
| System cmd ->
|
||||||
let cmd = f ~dir cmd in
|
|
||||||
let path, arg, err =
|
let path, arg, err =
|
||||||
Utils.system_shell ~needed_to:"interpret (system ...) actions"
|
Utils.system_shell ~needed_to:"interpret (system ...) actions"
|
||||||
in
|
in
|
||||||
|
@ -241,29 +232,29 @@ module Shexp = struct
|
||||||
run ~dir ~env ~env_extra ~stdout_to ~tail
|
run ~dir ~env ~env_extra ~stdout_to ~tail
|
||||||
(Path.to_string path) [arg; cmd]
|
(Path.to_string path) [arg; cmd]
|
||||||
|
|
||||||
and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f =
|
and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
|
||||||
match l with
|
match l with
|
||||||
| [] ->
|
| [] ->
|
||||||
if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
|
if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
|
||||||
Future.return ()
|
Future.return ()
|
||||||
| [t] ->
|
| [t] ->
|
||||||
exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f
|
exec t ~dir ~env ~env_extra ~stdout_to ~tail
|
||||||
| t :: rest ->
|
| t :: rest ->
|
||||||
exec t ~dir ~env ~env_extra ~stdout_to ~tail:false ~f >>= fun () ->
|
exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () ->
|
||||||
exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail ~f
|
exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
|
||||||
|
|
||||||
let exec t ~dir ~env ~f =
|
let exec t ~dir ~env =
|
||||||
exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true ~f
|
exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true
|
||||||
end
|
end
|
||||||
|
|
||||||
let user_action action ~dir ~env ~targets ~expand:f =
|
let user_action action ~dir ~env ~targets =
|
||||||
prim ~targets (fun () ->
|
prim ~targets (fun () ->
|
||||||
match (action : _ User_action.t) with
|
match (action : _ User_action.t) with
|
||||||
| Bash cmd ->
|
| Bash cmd ->
|
||||||
Future.run Strict ~dir:(Path.to_string dir) ~env
|
Future.run Strict ~dir:(Path.to_string dir) ~env
|
||||||
"/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; f ~dir cmd]
|
"/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||||
| Shexp shexp ->
|
| Shexp shexp ->
|
||||||
Shexp.exec ~dir ~env ~f shexp)
|
Shexp.exec ~dir ~env shexp)
|
||||||
|
|
||||||
let echo fn =
|
let echo fn =
|
||||||
create_file ~target:fn (fun data ->
|
create_file ~target:fn (fun data ->
|
||||||
|
|
|
@ -65,11 +65,10 @@ val run
|
||||||
-> ('a, unit) t
|
-> ('a, unit) t
|
||||||
|
|
||||||
val user_action
|
val user_action
|
||||||
: 'a User_action.t
|
: string User_action.t
|
||||||
-> dir:Path.t
|
-> dir:Path.t
|
||||||
-> env:string array
|
-> env:string array
|
||||||
-> targets:Path.t list
|
-> targets:Path.t list
|
||||||
-> expand:(dir:Path.t -> 'a -> string)
|
|
||||||
-> (unit, unit) t
|
-> (unit, unit) t
|
||||||
|
|
||||||
(** Create a file with the given contents. *)
|
(** Create a file with the given contents. *)
|
||||||
|
|
|
@ -1354,12 +1354,12 @@ module Gen(P : Params) = struct
|
||||||
add_artifact acc ~var ~lib_dep res
|
add_artifact acc ~var ~lib_dep res
|
||||||
| _ -> acc)
|
| _ -> acc)
|
||||||
|
|
||||||
let expand_string_with_vars ~artifacts ~targets ~deps =
|
let expand_string_with_vars =
|
||||||
let dep_exn ~dir name = function
|
let dep_exn ~dir name = function
|
||||||
| Some dep -> Path.reach ~from:dir dep
|
| Some dep -> Path.reach ~from:dir dep
|
||||||
| None -> die "cannot use ${%s} with files_recursively_in" name
|
| None -> die "cannot use ${%s} with files_recursively_in" name
|
||||||
in
|
in
|
||||||
let lookup ~dir var_name =
|
fun ~artifacts ~targets ~deps dir var_name ->
|
||||||
match String_map.find var_name artifacts with
|
match String_map.find var_name artifacts with
|
||||||
| Some path -> Some (Path.reach ~from:dir path)
|
| Some path -> Some (Path.reach ~from:dir path)
|
||||||
| None ->
|
| None ->
|
||||||
|
@ -1371,9 +1371,6 @@ module Gen(P : Params) = struct
|
||||||
let deps = List.map deps ~f:(dep_exn ~dir var_name) in
|
let deps = List.map deps ~f:(dep_exn ~dir var_name) in
|
||||||
Some (String.concat ~sep:" " deps)
|
Some (String.concat ~sep:" " deps)
|
||||||
| _ -> root_var_lookup ~dir var_name
|
| _ -> root_var_lookup ~dir var_name
|
||||||
in
|
|
||||||
fun ~dir str ->
|
|
||||||
String_with_vars.expand str ~f:(lookup ~dir)
|
|
||||||
|
|
||||||
let run t ~dir ~dep_kind ~targets ~deps =
|
let run t ~dir ~dep_kind ~targets ~deps =
|
||||||
let deps =
|
let deps =
|
||||||
|
@ -1382,6 +1379,10 @@ module Gen(P : Params) = struct
|
||||||
~f:(Path.relative dir))
|
~f:(Path.relative dir))
|
||||||
in
|
in
|
||||||
let forms = extract_artifacts ~dir t in
|
let forms = extract_artifacts ~dir t in
|
||||||
|
let t =
|
||||||
|
User_action.Unexpanded.expand dir t
|
||||||
|
~f:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps)
|
||||||
|
in
|
||||||
let build =
|
let build =
|
||||||
Build.record_lib_deps ~dir ~kind:dep_kind
|
Build.record_lib_deps ~dir ~kind:dep_kind
|
||||||
(String_set.elements forms.lib_deps
|
(String_set.elements forms.lib_deps
|
||||||
|
@ -1390,7 +1391,6 @@ module Gen(P : Params) = struct
|
||||||
Build.paths (String_map.values forms.artifacts)
|
Build.paths (String_map.values forms.artifacts)
|
||||||
>>>
|
>>>
|
||||||
Build.user_action t ~dir ~env:ctx.env ~targets
|
Build.user_action t ~dir ~env:ctx.env ~targets
|
||||||
~expand:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps)
|
|
||||||
in
|
in
|
||||||
match forms.failures with
|
match forms.failures with
|
||||||
| [] -> build
|
| [] -> build
|
||||||
|
|
|
@ -89,12 +89,25 @@ let expand t ~f =
|
||||||
| Braces -> sprintf "${%s}" v)
|
| Braces -> sprintf "${%s}" v)
|
||||||
|> String.concat ~sep:""
|
|> String.concat ~sep:""
|
||||||
|
|
||||||
|
let expand_with_context context t ~f =
|
||||||
|
List.map t ~f:(function
|
||||||
|
| Text s -> s
|
||||||
|
| Var (syntax, v) ->
|
||||||
|
match f context v with
|
||||||
|
| Some x -> x
|
||||||
|
| None ->
|
||||||
|
match syntax with
|
||||||
|
| Parens -> sprintf "$(%s)" v
|
||||||
|
| Braces -> sprintf "${%s}" v)
|
||||||
|
|> String.concat ~sep:""
|
||||||
|
|
||||||
module type Container = sig
|
module type Container = sig
|
||||||
type 'a t
|
type 'a t
|
||||||
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
|
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
|
||||||
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
|
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
|
||||||
|
|
||||||
val map : 'a t -> f:('a -> 'b) -> 'b t
|
type context
|
||||||
|
val expand : context -> 'a t -> f:(context -> 'a -> string) -> string t
|
||||||
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
|
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -107,6 +120,7 @@ module Lift(M : Container) = struct
|
||||||
let fold t ~init ~f =
|
let fold t ~init ~f =
|
||||||
M.fold t ~init ~f:(fun acc x -> fold x ~init:acc ~f)
|
M.fold t ~init ~f:(fun acc x -> fold x ~init:acc ~f)
|
||||||
|
|
||||||
let expand t ~f = M.map t ~f:(expand ~f)
|
let expand context (t : t) ~f =
|
||||||
|
M.expand context t ~f:(expand_with_context ~f)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
|
@ -22,7 +22,8 @@ module type Container = sig
|
||||||
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
|
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
|
||||||
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
|
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
|
||||||
|
|
||||||
val map : 'a t -> f:('a -> 'b) -> 'b t
|
type context
|
||||||
|
val expand : context -> 'a t -> f:(context -> 'a -> string) -> string t
|
||||||
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
|
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -34,5 +35,9 @@ module Lift(M : Container) : sig
|
||||||
|
|
||||||
val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
|
val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
|
||||||
|
|
||||||
val expand : t -> f:(string -> string option) -> string M.t
|
val expand
|
||||||
|
: M.context
|
||||||
|
-> t
|
||||||
|
-> f:(M.context -> string -> string option)
|
||||||
|
-> string M.t
|
||||||
end
|
end
|
||||||
|
|
|
@ -30,17 +30,24 @@ module Mini_shexp = struct
|
||||||
]
|
]
|
||||||
sexp
|
sexp
|
||||||
|
|
||||||
let rec map t ~f =
|
let rec expand dir t ~f =
|
||||||
match t with
|
match t with
|
||||||
| Run (prog, args) -> Run (f prog, List.map args ~f)
|
| Run (prog, args) ->
|
||||||
| Chdir (fn, t) -> Chdir (f fn, map t ~f)
|
Run (f dir prog,
|
||||||
| Setenv (var, value, t) -> Setenv (f var, f value, map t ~f)
|
List.map args ~f:(fun arg -> f dir arg))
|
||||||
| With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f)
|
| Chdir (fn, t) ->
|
||||||
| Progn l -> Progn (List.map l ~f:(map ~f))
|
let fn = f dir fn in
|
||||||
| Echo x -> Echo (f x)
|
Chdir (fn, expand (Path.relative dir fn) t ~f)
|
||||||
| Cat x -> Cat (f x)
|
| Setenv (var, value, t) ->
|
||||||
| Copy_and_add_line_directive (x, y) -> Copy_and_add_line_directive (f x, f y)
|
Setenv (f dir var, f dir value, expand dir t ~f)
|
||||||
| System x -> System (f x)
|
| With_stdout_to (fn, t) ->
|
||||||
|
With_stdout_to (f dir fn, expand dir t ~f)
|
||||||
|
| Progn l -> Progn (List.map l ~f:(fun t -> expand dir t ~f))
|
||||||
|
| Echo x -> Echo (f dir x)
|
||||||
|
| Cat x -> Cat (f dir x)
|
||||||
|
| Copy_and_add_line_directive (x, y) ->
|
||||||
|
Copy_and_add_line_directive (f dir x, f dir y)
|
||||||
|
| System x -> System (f dir x)
|
||||||
|
|
||||||
let rec fold t ~init:acc ~f =
|
let rec fold t ~init:acc ~f =
|
||||||
match t with
|
match t with
|
||||||
|
@ -77,10 +84,12 @@ module T = struct
|
||||||
| Atom _ -> Bash (a sexp)
|
| Atom _ -> Bash (a sexp)
|
||||||
| List _ -> Shexp (Mini_shexp.t a sexp)
|
| List _ -> Shexp (Mini_shexp.t a sexp)
|
||||||
|
|
||||||
let map t ~f =
|
type context = Path.t
|
||||||
|
|
||||||
|
let expand dir t ~f =
|
||||||
match t with
|
match t with
|
||||||
| Bash x -> Bash (f x)
|
| Bash x -> Bash (f dir x)
|
||||||
| Shexp x -> Shexp (Mini_shexp.map x ~f)
|
| Shexp x -> Shexp (Mini_shexp.expand dir x ~f)
|
||||||
|
|
||||||
let fold t ~init ~f =
|
let fold t ~init ~f =
|
||||||
match t with
|
match t with
|
||||||
|
|
Loading…
Reference in New Issue