diff --git a/CHANGES.org b/CHANGES.org index f9a25b97..b8ec80ee 100644 --- a/CHANGES.org +++ b/CHANGES.org @@ -5,6 +5,8 @@ - Improve the output of jbuilder, in particular don't mangle the output of commands when using =-j N= with =N > 1= +- Support incremental compilation + - Strengthen the scope of a package. Jbuilder knows about package =foo= only in the sub-tree starting from where =foo.opam= lives diff --git a/bin/main.ml b/bin/main.ml index 9c368462..6844410b 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -11,6 +11,7 @@ let (>>=) = Future.(>>=) type common = { concurrency : int ; debug_rules : bool + ; debug_actions : bool ; debug_dep_path : bool ; debug_findlib : bool ; dev_mode : bool @@ -25,6 +26,7 @@ let prefix_target common s = common.target_prefix ^ s let set_common c = Clflags.concurrency := c.concurrency; Clflags.debug_rules := c.debug_rules; + Clflags.debug_actions := c.debug_actions; Clflags.debug_dep_path := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; Clflags.dev_mode := c.dev_mode; @@ -111,6 +113,7 @@ let common = concurrency only_packages debug_rules + debug_actions debug_dep_path debug_findlib dev_mode @@ -124,6 +127,7 @@ let common = in { concurrency ; debug_rules + ; debug_actions ; debug_dep_path ; debug_findlib ; dev_mode @@ -160,6 +164,13 @@ let common = ~doc:"Print all internal rules." ) in + let dactions = + Arg.(value + & flag + & info ["debug-actions"] ~docs + ~doc:"Print out internal actions." + ) + in let ddep_path = Arg.(value & flag @@ -199,6 +210,7 @@ let common = $ concurrency $ only_packages $ drules + $ dactions $ ddep_path $ dfindlib $ dev diff --git a/doc/manual.org b/doc/manual.org index d0e1166b..f9d232b1 100644 --- a/doc/manual.org +++ b/doc/manual.org @@ -826,24 +826,17 @@ build context as the jbuild they are defined in. So for instance an action defined in =src/foo/jbuild= will be run from =_build//src/foo=. -The argument of an =(action ...)= field can use one of these two -forms: +The argument of =(action ...)= fields is a small DSL that is +interpreted by jbuilder directly and doesn't require an external +shell. All atoms in the DSL support [[Variables expansion][variables expansion]]. Moreover, you +don't need to specify dependencies explicitly for the special +=${:...}= forms, these are recognized and automatically handled +by Jbuilder. -- a simple string, in which case it is passed to =bash= -- using a small DSL, that is interpreted by jbuilder directly and - doesn't require an external shell - -In both case, all atoms in the argument of this field supports -[[Variables - expansion][variables expansion]]. Moreover, you don't need to specify dependencies -explicitly for the special =${:...}= forms, these are recognized -automatically handled by Jbuilder. - -The DSL is preferable in general as it will make your package more -portable. It is currently quite limited, so the recommendation is to -write a small OCaml program and use the DSL to invoke it. You can use -[[https://github.com/janestreet/shexp][shexp]] to write portable scripts or [[https://github.com/janestreet/configurator][configurator]] for configuration -related tasks. +The DSL is currently quite limited, so if you want to do something +complicated it is recommended to write a small OCaml program and use +the DSL to invoke it. You can use [[https://github.com/janestreet/shexp][shexp]] to write portable scripts or +[[https://github.com/janestreet/configurator][configurator]] for configuration related tasks. The following constructions are available: @@ -858,6 +851,8 @@ The following constructions are available: - =(copy-and-add-line-directive )= to copy a file and add a line directive at the beginning - =(system )= to execute a command using the system shell: =sh= on Unix and =cmd= on Windows +- =(bash )= to execute a command using =/bin/bash=. This is + obviously not very portable Note: expansion of the special =${:...}= is done relative to the current working directory of the part of the DSL being executed. So @@ -879,7 +874,7 @@ in =src/foo=: (rule ((targets (blah.ml)) (deps (blah.mll)) - (action (ocamllex -o ${@} ${<})))) + (action (run ocamllex -o ${@} ${<})))) #+end_src Here the command that will be executed is: @@ -904,7 +899,7 @@ the root of your project. What you should write instead is: (rule ((targets (blah.ml)) (deps (blah.mll)) - (action (chdir ${ROOT} (ocamllex -o ${@} ${<}))))) + (action (chdir ${ROOT} (run ocamllex -o ${@} ${<}))))) #+end_src ** jbuild-ignore diff --git a/src/action.ml b/src/action.ml index b7196acd..f274750b 100644 --- a/src/action.ml +++ b/src/action.ml @@ -1,98 +1,321 @@ open Import open Sexp.Of_sexp +type var_expansion = + | Not_found + | Path of Path.t + | Paths of Path.t list + | Str of string + +let expand_str ~dir ~f template = + String_with_vars.expand template ~f:(fun var -> + match f var with + | Not_found -> None + | Path path -> Some (Path.reach ~from:dir path) + | Paths l -> Some (List.map l ~f:(Path.reach ~from:dir) |> String.concat ~sep:" ") + | Str s -> Some s) + +let expand_path ~dir ~f template = + match String_with_vars.just_a_var template with + | None -> expand_str ~dir ~f template |> Path.relative dir + | Some v -> + match f v with + | Not_found -> expand_str ~dir ~f template |> Path.relative dir + | Path p + | Paths [p] -> p + | Str s -> Path.relative dir s + | Paths l -> + List.map l ~f:(Path.reach ~from:dir) + |> String.concat ~sep:" " + |> Path.relative dir + module Mini_shexp = struct - type 'a t = - | Run of 'a * 'a list - | Chdir of 'a * 'a t - | Setenv of 'a * 'a * 'a t - | With_stdout_to of 'a * 'a t - | Progn of 'a t list - | Echo of 'a - | Cat of 'a - | Copy_and_add_line_directive of 'a * 'a - | System of 'a + module Ast = struct + type ('a, 'path) t = + | Run of 'path * 'a list + | Chdir of 'path * ('a, 'path) t + | Setenv of 'a * 'a * ('a, 'path) t + | With_stdout_to of 'path * ('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 + | Write_file of 'path * 'a - let rec t a sexp = - sum - [ cstr_rest "run" (a @> nil) a (fun prog args -> Run (prog, args)) - ; cstr "chdir" (a @> t a @> nil) (fun dn t -> Chdir (dn, t)) - ; cstr "setenv" (a @> a @> t a @> nil) (fun k v t -> Setenv (k, v, t)) - ; cstr "with-stdout-to" (a @> t a @> nil) (fun fn t -> With_stdout_to (fn, t)) - ; cstr_rest "progn" nil (t a) (fun l -> Progn l) - ; cstr "echo" (a @> nil) (fun x -> Echo x) - ; cstr "cat" (a @> nil) (fun x -> Cat x) - ; cstr "copy" (a @> a @> nil) (fun src dst -> - With_stdout_to (dst, Cat src)) - ; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst -> - Copy_and_add_line_directive (src, dst)) - ; cstr "system" (a @> nil) (fun cmd -> System cmd) - ] - sexp + 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 -> With_stdout_to (fn, 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 - let rec map t ~f = + 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] + | With_stdout_to (fn, r) -> List [Atom "with-stdout-to"; g fn; 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] + | Write_file (x, y) -> List [Atom "write-file"; g x; f y] + + 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 + | With_stdout_to (fn, t) -> fold t ~init:(f acc fn) ~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 + | Write_file (x, y) -> f (f acc x) y + 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 + + 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 dir t ~f : (string, Path.t) Ast.t = + match t with + | Run (prog, args) -> + Run (expand_path ~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 fn t ~f) + | Setenv (var, value, t) -> + Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value, + expand dir t ~f) + | With_stdout_to (fn, t) -> + With_stdout_to (expand_path ~dir ~f fn, expand dir t ~f) + | Progn l -> Progn (List.map l ~f:(fun t -> expand 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) + | Write_file (x, y) -> Write_file (expand_path ~dir ~f x, expand_str ~dir ~f y) + end + + open Future + + let run ~dir ~env ~env_extra ~stdout_to ~tail prog args = + let stdout_to : Future.stdout_to = + match stdout_to with + | None -> Terminal + | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc } + in + let env = Context.extend_env ~vars:env_extra ~env in + Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to + (Path.reach_for_running ~from:dir prog) args + + let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail = match t with - | Run (prog, args) -> Run (f prog, List.map args ~f) - | Chdir (fn, t) -> Chdir (f fn, map t ~f) - | Setenv (var, value, t) -> Setenv (f var, f value, map t ~f) - | With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f) - | Progn l -> Progn (List.map l ~f:(map ~f)) - | Echo x -> Echo (f x) - | Cat x -> Cat (f x) - | Copy_and_add_line_directive (x, y) -> Copy_and_add_line_directive (f x, f y) - | System x -> System (f x) + | Run (prog, args) -> + run ~dir ~env ~env_extra ~stdout_to ~tail prog args + | Chdir (dir, t) -> + exec t ~env ~env_extra ~stdout_to ~tail ~dir + | Setenv (var, value, t) -> + exec t ~dir ~env ~stdout_to ~tail + ~env_extra:(String_map.add env_extra ~key:var ~data:value) + | With_stdout_to (fn, t) -> + if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); + let fn = Path.to_string fn in + exec t ~dir ~env ~env_extra ~tail + ~stdout_to:(Some (fn, open_out_bin fn)) + | Progn l -> + exec_list l ~dir ~env ~env_extra ~stdout_to ~tail + | Echo str -> + return + (match stdout_to with + | None -> print_string str; flush stdout + | Some (_, oc) -> + output_string oc str; + if tail then close_out oc) + | Cat fn -> + with_file_in (Path.to_string fn) ~f:(fun ic -> + match stdout_to with + | None -> copy_channels ic stdout + | Some (_, oc) -> + copy_channels ic oc; + if tail then close_out 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) -> + copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst); + return () + | Symlink (src, dst) -> + if Sys.win32 then + 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) -> + with_file_in (Path.to_string src) ~f:(fun ic -> + with_file_out (Path.to_string dst) ~f:(fun oc -> + let fn = + match Path.extract_build_context src with + | None -> src + | Some (_, rem) -> rem + in + Printf.fprintf oc "# 1 %S\n" (Path.to_string fn); + copy_channels ic oc)); + return () + | System cmd -> begin + let path, arg, err = + Utils.system_shell ~needed_to:"interpret (system ...) actions" + in + match err with + | Some err -> err.fail () + | None -> + run ~dir ~env ~env_extra ~stdout_to ~tail path [arg; cmd] + end + | Bash cmd -> + run ~dir ~env ~env_extra ~stdout_to ~tail + (Path.absolute "/bin/bash") + ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] + | Write_file (fn, s) -> + let fn = Path.to_string fn in + if Sys.file_exists fn && read_file fn = s then + () + else + write_file fn s; + return () - 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 - | With_stdout_to (fn, t) -> fold t ~init:(f acc fn) ~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 - | Copy_and_add_line_directive (x, y) -> f (f acc x) y - | System x -> f acc x - - let rec sexp_of_t f : _ -> Sexp.t = function - | Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f) - | Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r] - | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f r] - | With_stdout_to (fn, r) -> List [Atom "with-stdout-to"; f fn; sexp_of_t f r] - | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f)) - | Echo x -> List [Atom "echo"; f x] - | Cat x -> List [Atom "cat"; f x] - | Copy_and_add_line_directive (x, y) -> - List [Atom "copy-and-add-line-directive"; f x; f y] - | System x -> List [Atom "system"; f x] + and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail = + match l with + | [] -> + if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); + Future.return () + | [t] -> + exec t ~dir ~env ~env_extra ~stdout_to ~tail + | t :: rest -> + exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () -> + exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail end -module T = struct - type 'a t = - | Bash of 'a - | Shexp of 'a Mini_shexp.t +type t = + { context : Context.t option + ; dir : Path.t + ; action : Mini_shexp.t + } - let t a sexp = - match sexp with - | Atom _ -> Bash (a sexp) - | List (_, [ Atom (_, "bash"); x ]) -> Bash (a x) - | List _ -> Shexp (Mini_shexp.t a sexp) +let t contexts sexp = + let open Sexp.Of_sexp in + let context sexp = + let name = string sexp in + match String_map.find name contexts with + | None -> of_sexp_errorf sexp "Context %s not found" name + | Some c -> c + in + record + (field_o "context" context >>= fun context -> + field "dir" Path.t >>= fun dir -> + field "action" Mini_shexp.t >>= fun action -> + return { context; dir; action }) + sexp - let map t ~f = - match t with - | Bash x -> Bash (f x) - | Shexp x -> Shexp (Mini_shexp.map x ~f) +let sexp_of_t { context; dir; action } = + let fields : Sexp.t list = + [ List [ Atom "dir" ; Path.sexp_of_t dir ] + ; 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 fold t ~init ~f = - match t with - | Bash x -> f init x - | Shexp x -> Mini_shexp.fold x ~init ~f +let exec { action; dir; context } = + let env = + match context with + | None -> Lazy.force Context.initial_env + | Some c -> c.env + in + Mini_shexp.exec action ~dir ~env ~env_extra:String_map.empty + ~stdout_to:None ~tail:true - let sexp_of_t f : _ -> Sexp.t = function - | Bash a -> List [Atom "bash" ; f a] - | Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a] -end +type for_hash = string option * Path.t * Mini_shexp.t -include T - -module Unexpanded = String_with_vars.Lift(T) +let for_hash { context; dir; action } = + (Option.map context ~f:(fun c -> c.name), + dir, + action) diff --git a/src/action.mli b/src/action.mli new file mode 100644 index 00000000..9184a422 --- /dev/null +++ b/src/action.mli @@ -0,0 +1,55 @@ +open! Import + +type var_expansion = + | Not_found + | Path of Path.t + | Paths of Path.t list + | Str of string + +module Mini_shexp : sig + module Ast : sig + type ('a, 'path) t = + | Run of 'path * 'a list + | Chdir of 'path * ('a, 'path) t + | Setenv of 'a * 'a * ('a, 'path) t + | With_stdout_to of 'path * ('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 + | Write_file of 'path * 'a + 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 : t Sexp.Of_sexp.t + val sexp_of_t : t Sexp.To_sexp.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 -> string -> 'a) -> 'a + val expand : Path.t -> t -> f:(string -> var_expansion) -> desc + end with type desc := t +end + +type t = + { context : Context.t option + ; dir : Path.t + ; action : Mini_shexp.t + } + +val t : Context.t String_map.t -> t Sexp.Of_sexp.t +val sexp_of_t : t Sexp.To_sexp.t +val exec : t -> unit Future.t + +type for_hash +val for_hash : t -> for_hash diff --git a/src/alias.ml b/src/alias.ml index e6a10435..16ac4df0 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -91,6 +91,6 @@ let rules store ~prefixes ~tree = let rule = Build_interpret.Rule.make (Build.path_set deps >>> - Build.touch alias.file) + Build.create_file alias.file) in rule :: acc) diff --git a/src/ansi_color.ml b/src/ansi_color.ml index 93f7696b..cd89500e 100644 --- a/src/ansi_color.ml +++ b/src/ansi_color.ml @@ -168,13 +168,14 @@ let setup_env_for_ocaml_colors = lazy( ) let styles_of_tag = function - | "loc" -> [Bold] - | "error" -> [Bold; Foreground Red] + | "loc" -> [Bold] + | "error" -> [Bold; Foreground Red] | "warning" -> [Bold; Foreground Magenta] - | "kwd" -> [Bold; Foreground Blue] - | "id" -> [Bold; Foreground Yellow] - | "prompt" -> [Bold; Foreground Green] - | _ -> [] + | "kwd" -> [Bold; Foreground Blue] + | "id" -> [Bold; Foreground Yellow] + | "prompt" -> [Bold; Foreground Green] + | "debug" -> [Underlined; Foreground Bright_cyan] + | _ -> [] let setup_err_formatter_colors () = let open Format in diff --git a/src/build.ml b/src/build.ml index 73eb6360..024be6da 100644 --- a/src/build.ml +++ b/src/build.ml @@ -18,14 +18,10 @@ type lib_dep_kind = type lib_deps = lib_dep_kind String_map.t module Repr = struct - type ('a, 'b) prim = - { targets : Path.t list - ; exec : 'a -> 'b Future.t - } type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t - | Prim : ('a, 'b) prim -> ('a, 'b) t - | Store_vfile : 'a Vspec.t -> ('a, unit) t + | Targets : Path.t list -> ('a, 'a) t + | Store_vfile : 'a Vspec.t -> ('a, Action.t) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t @@ -121,13 +117,6 @@ let files_recursively_in ~dir = in path_set (loop src_dir Pset.empty) -let prim ~targets exec = Prim { targets; exec } - -let create_files ~targets exec = - prim ~targets (fun x -> Future.return (exec x)) -let create_file ~target exec = - create_files ~targets:[target] exec - let store_vfile spec = Store_vfile spec let get_prog (prog : _ Prog_spec.t) = @@ -145,7 +134,7 @@ let prog_and_args ~dir prog args = >>> arr fst)) -let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args = +let run ?(dir=Path.root) ?stdout_to ?context ?(extra_targets=[]) prog args = let extra_targets = match stdout_to with | None -> extra_targets @@ -154,164 +143,50 @@ let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args = let targets = Arg_spec.add_targets args extra_targets in prog_and_args ~dir prog args >>> - prim ~targets - (fun (prog, args) -> - let stdout_to = - match stdout_to with - | None -> Future.Terminal - | Some path -> File (Path.to_string path) - in - Future.run Strict ~dir:(Path.to_string dir) ~stdout_to ?env - (Path.reach prog ~from:dir) args) - -let run_capture_gen ~f ?(dir=Path.root) ?env prog args = - let targets = Arg_spec.add_targets args [] in - prog_and_args ~dir prog args - >>> - prim ~targets - (fun (prog, args) -> - f ?dir:(Some (Path.to_string dir)) ?env - Future.Strict (Path.reach prog ~from:dir) args) - -let run_capture ?dir ?env prog args = - run_capture_gen ~f:Future.run_capture ?dir ?env prog args -let run_capture_lines ?dir ?env prog args = - run_capture_gen ~f:Future.run_capture_lines ?dir ?env prog args - -module Shexp = struct - open Future - open Action.Mini_shexp - - let run ~dir ~env ~env_extra ~stdout_to ~tail prog args = - let stdout_to : Future.stdout_to = + Targets targets + >>^ (fun (prog, args) -> + let action : Action.Mini_shexp.t = Run (prog, args) in + let action = match stdout_to with - | None -> Terminal - | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc } + | None -> action + | Some path -> With_stdout_to (path, action) in - let env = Context.extend_env ~vars:env_extra ~env in - Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args + { Action. + dir + ; context + ; action + }) - let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f = - match t with - | 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 - | Chdir (fn, t) -> - let fn = f ~dir fn in - exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn) ~f - | Setenv (var, value, t) -> - let var = f ~dir var in - 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) - | With_stdout_to (fn, t) -> - let fn = f ~dir fn in - if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); - let fn = Path.to_string (Path.relative dir fn) in - exec t ~dir ~env ~env_extra ~tail ~f - ~stdout_to:(Some (fn, open_out_bin fn)) - | Progn l -> - exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f - | Echo str -> - let str = f ~dir str in - return - (match stdout_to with - | None -> print_string str; flush stdout - | Some (_, oc) -> - output_string oc str; - if tail then close_out oc) - | Cat fn -> - let fn = f ~dir fn in - let fn = Path.to_string (Path.relative dir fn) in - with_file_in fn ~f:(fun ic -> - match stdout_to with - | None -> copy_channels ic stdout - | Some (_, oc) -> - copy_channels ic oc; - if tail then close_out oc); - return () - | Copy_and_add_line_directive (src, dst) -> - let src = Path.relative dir (f ~dir src) in - let dst = Path.relative dir (f ~dir dst) in - with_file_in (Path.to_string src) ~f:(fun ic -> - with_file_out (Path.to_string dst) ~f:(fun oc -> - let fn = - match Path.extract_build_context src with - | None -> src - | Some (_, rem) -> rem - in - Printf.fprintf oc "# 1 %S\n" (Path.to_string fn); - copy_channels ic oc)); - return () - | System cmd -> - let cmd = f ~dir cmd in - let path, arg, err = - Utils.system_shell ~needed_to:"interpret (system ...) actions" - in - match err with - | Some err -> err.fail () - | None -> - run ~dir ~env ~env_extra ~stdout_to ~tail - (Path.to_string path) [arg; cmd] +let action ?(dir=Path.root) ?context ~targets action = + Targets targets + >>^ fun () -> + { Action. context; dir; action } - and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f = - match l with - | [] -> - if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc); - Future.return () - | [t] -> - exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f - | t :: rest -> - exec t ~dir ~env ~env_extra ~stdout_to ~tail:false ~f >>= fun () -> - exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail ~f +let echo fn s = + action ~targets:[fn] (Write_file (fn, s)) - let exec t ~dir ~env ~f = - exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true ~f -end - -let action action ~dir ~env ~targets ~expand:f = - prim ~targets (fun () -> - match (action : _ Action.t) with - | Bash cmd -> - Future.run Strict ~dir:(Path.to_string dir) ~env - "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; f ~dir cmd] - | Shexp shexp -> - Shexp.exec ~dir ~env ~f shexp) - -let echo fn = - create_file ~target:fn (fun data -> - with_file_out (Path.to_string fn) ~f:(fun oc -> output_string oc data)) +let echo_dyn fn = + Targets [fn] + >>^ fun s -> + { Action. + context = None + ; dir = Path.root + ; action = Write_file (fn, s) + } let copy ~src ~dst = path src >>> - create_file ~target:dst (fun () -> - copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)) + action ~targets:[dst] (Copy (src, dst)) let symlink ~src ~dst = - if Sys.win32 then - copy ~src ~dst - else - path src >>> - create_file ~target:dst (fun () -> - 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) + path src >>> + action ~targets:[dst] (Symlink (src, dst)) -let touch target = - create_file ~target (fun _ -> - Unix.close - (Unix.openfile (Path.to_string target) - [O_CREAT; O_TRUNC; O_WRONLY] 0o666)) +let create_file fn = + action ~targets:[fn] (Create_file fn) + +let and_create_file fn = + arr (fun (action : Action.t) -> + { action with + action = Progn [action.action; Create_file fn] + }) diff --git a/src/build.mli b/src/build.mli index ebde3cc3..5272c1b6 100644 --- a/src/build.mli +++ b/src/build.mli @@ -8,14 +8,11 @@ val arr : ('a -> 'b) -> ('a, 'b) t val return : 'a -> (unit, 'a) t -val create_file : target:Path.t -> ('a -> 'b) -> ('a, 'b) t -val create_files : targets:Path.t list -> ('a -> 'b) -> ('a, 'b) t - module Vspec : sig type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t end -val store_vfile : 'a Vspec.t -> ('a, unit) t +val store_vfile : 'a Vspec.t -> ('a, Action.t) t module O : sig val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t @@ -58,42 +55,30 @@ end val run : ?dir:Path.t -> ?stdout_to:Path.t - -> ?env:string array + -> ?context:Context.t -> ?extra_targets:Path.t list -> 'a Prog_spec.t -> 'a Arg_spec.t list - -> ('a, unit) t - -val run_capture - : ?dir:Path.t - -> ?env:string array - -> 'a Prog_spec.t - -> 'a Arg_spec.t list - -> ('a, string) t - -val run_capture_lines - : ?dir:Path.t - -> ?env:string array - -> 'a Prog_spec.t - -> 'a Arg_spec.t list - -> ('a, string list) t + -> ('a, Action.t) t val action - : 'a Action.t - -> dir:Path.t - -> env:string array + : ?dir:Path.t + -> ?context:Context.t -> targets:Path.t list - -> expand:(dir:Path.t -> 'a -> string) - -> (unit, unit) t + -> Action.Mini_shexp.t + -> (unit, Action.t) t (** Create a file with the given contents. *) -val echo : Path.t -> (string, unit) t +val echo : Path.t -> string -> (unit, Action.t) t +val echo_dyn : Path.t -> (string, Action.t) t -val copy : src:Path.t -> dst:Path.t -> (unit, unit) t +val copy : src:Path.t -> dst:Path.t -> (unit, Action.t) t -val symlink : src:Path.t -> dst:Path.t -> (unit, unit) t +val symlink : src:Path.t -> dst:Path.t -> (unit, Action.t) t -val touch : Path.t -> (unit, unit) t +val create_file : Path.t -> (unit, Action.t) t + +val and_create_file : Path.t -> (Action.t, Action.t) t type lib_dep_kind = | Optional @@ -111,14 +96,10 @@ type lib_deps = lib_dep_kind String_map.t module Repr : sig - type ('a, 'b) prim = - { targets : Path.t list - ; exec : 'a -> 'b Future.t - } type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t - | Prim : ('a, 'b) prim -> ('a, 'b) t - | Store_vfile : 'a Vspec.t -> ('a, unit) t + | Targets : Path.t list -> ('a, 'a) t + | Store_vfile : 'a Vspec.t -> ('a, Action.t) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 5899f177..b016acaf 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -23,7 +23,7 @@ let deps t ~all_targets_by_dir = let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc -> match t with | Arr _ -> acc - | Prim _ -> acc + | Targets _ -> acc | Store_vfile _ -> acc | Compose (a, b) -> loop a (loop b acc) | First t -> loop t acc @@ -50,7 +50,7 @@ let lib_deps = = fun t acc -> match t with | Arr _ -> acc - | Prim _ -> acc + | Targets _ -> acc | Store_vfile _ -> acc | Compose (a, b) -> loop a (loop b acc) | First t -> loop t acc @@ -76,7 +76,7 @@ let targets = let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc -> match t with | Arr _ -> acc - | Prim { targets; _ } -> + | Targets targets -> List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc) | Store_vfile spec -> Vfile spec :: acc | Compose (a, b) -> loop a (loop b acc) @@ -95,7 +95,7 @@ let targets = module Rule = struct type t = - { build : (unit, unit) Build.t + { build : (unit, Action.t) Build.t ; targets : Target.t list } diff --git a/src/build_interpret.mli b/src/build_interpret.mli index 60aead68..025454eb 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -11,11 +11,11 @@ end module Rule : sig type t = - { build : (unit, unit) Build.t + { build : (unit, Action.t) Build.t ; targets : Target.t list } - val make : (unit, unit) Build.t -> t + val make : (unit, Action.t) Build.t -> t end val deps diff --git a/src/build_system.ml b/src/build_system.ml index 8e723d7d..97336e8c 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -20,12 +20,10 @@ end module Rule = struct type t = - { deps : Pset.t - ; targets : Pset.t - ; (* Keep the arrow around so that we can do more query, such as for finding external - library dependencies *) - build : (unit, unit) Build.t - ; mutable exec : Exec_status.t + { deps : Pset.t + ; targets : Pset.t + ; build : (unit, Action.t) Build.t + ; mutable exec : Exec_status.t } end @@ -58,10 +56,32 @@ end type t = { (* File specification by targets *) - files : (Path.t, File_spec.packed) Hashtbl.t - ; contexts : Context.t list + files : (Path.t, File_spec.packed) Hashtbl.t + ; contexts : Context.t list + ; (* Table from target to digest of [(deps, targets, action)] *) + trace : (Path.t, Digest.t) Hashtbl.t + ; timestamps : (Path.t, float) Hashtbl.t } +let timestamp t fn ~default = + match Hashtbl.find t.timestamps fn with + | Some ts -> ts + | None -> + match Unix.lstat (Path.to_string fn) with + | exception _ -> default + | stat -> + let ts = stat.st_mtime in + Hashtbl.add t.timestamps ~key:fn ~data:ts; + ts + +let min_timestamp t fns = + List.fold_left fns ~init:max_float + ~f:(fun acc fn -> min acc (timestamp t fn ~default:0.)) + +let max_timestamp t fns = + List.fold_left fns ~init:0. + ~f:(fun acc fn -> max acc (timestamp t fn ~default:max_float)) + let find_file_exn t file = Hashtbl.find_exn t.files file ~string_of_key:(fun fn -> sprintf "%S" (Path.to_string fn)) ~table_desc:(fun _ -> "") @@ -148,25 +168,30 @@ let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn let Eq = File_kind.eq_exn kind file.kind in file -let save_vfile (type a) (module K : Vfile_kind.S with type t = a) fn x = - K.save fn x +let vfile_to_string (type a) (module K : Vfile_kind.S with type t = a) fn x = + K.to_string fn x module Build_exec = struct open Build.Repr - let exec bs t x ~targeting = + let exec bs t x ~static_deps ~targeting = + let all_deps = ref static_deps in let rec exec : type a b. (a, b) t -> a -> b Future.t = fun t x -> let return = Future.return in match t with | Arr f -> return (f x) - | Prim { exec; _ } -> exec x + | Targets _ -> return x | Store_vfile (Vspec.T (fn, kind)) -> let file = get_file bs fn (Sexp_file kind) in assert (file.data = None); file.data <- Some x; - save_vfile kind fn x; - Future.return () + Future.return + { Action. + context = None + ; dir = Path.root + ; action = Write_file (fn, vfile_to_string kind fn x) + } | Compose (a, b) -> exec a x >>= exec b | First t -> @@ -189,12 +214,14 @@ module Build_exec = struct return (Option.value_exn file.data) | Dyn_paths t -> exec t x >>= fun fns -> + all_deps := Pset.union !all_deps (Pset.of_list fns); all_unit (List.rev_map fns ~f:(wait_for_file bs ~targeting)) >>= fun () -> return x | Record_lib_deps _ -> return x | Fail { fail } -> fail () in - exec (Build.repr t) x + exec (Build.repr t) x >>| fun action -> + (action, !all_deps) end let add_spec t fn spec ~allow_override = @@ -247,7 +274,32 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = all_unit (Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc)) >>= fun () -> - Build_exec.exec t build () ~targeting + Build_exec.exec t build () ~targeting ~static_deps:deps + >>= fun (action, all_deps) -> + if !Clflags.debug_actions then + Format.eprintf "@{Action@}: %s@." + (Sexp.to_string (Action.sexp_of_t action)); + let all_deps = Pset.elements all_deps in + let targets = Pset.elements targets in + let hash = + let trace = (all_deps, targets, Action.for_hash action) in + Digest.string (Marshal.to_string trace []) + in + let rule_changed = + List.fold_left targets ~init:false ~f:(fun acc fn -> + match Hashtbl.find t.trace fn with + | None -> + Hashtbl.add t.trace ~key:fn ~data:hash; + true + | Some prev_hash -> + Hashtbl.replace t.trace ~key:fn ~data:hash; + acc || prev_hash <> hash) + in + if rule_changed || min_timestamp t targets < max_timestamp t all_deps then begin + List.iter targets ~f:(Hashtbl.remove t.timestamps); + Action.exec action + end else + return () ) in let rule = { Rule. @@ -280,6 +332,36 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir = ~all_targets_by_dir ~allow_override:true)) +module Trace = struct + type t = (Path.t, Digest.t) Hashtbl.t + + let file = "_build/.db" + + let dump (trace : t) = + let sexp = + Sexp.List ( + Hashtbl.fold trace ~init:Pmap.empty ~f:(fun ~key ~data acc -> + Pmap.add acc ~key ~data) + |> Path.Map.bindings + |> List.map ~f:(fun (path, hash) -> + Sexp.List [ Atom (Path.to_string path); Atom (Digest.to_hex hash) ])) + in + write_file file (Sexp.to_string sexp) + + let load () = + let trace = Hashtbl.create 1024 in + if Sys.file_exists file then begin + let sexp = Sexp_load.single file in + let bindings = + let open Sexp.Of_sexp in + list (pair Path.t (fun s -> Digest.from_hex (string s))) sexp + in + List.iter bindings ~f:(fun (path, hash) -> + Hashtbl.add trace ~key:path ~data:hash); + end; + trace +end + let create ~contexts ~file_tree ~rules = let all_source_files = File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc -> @@ -311,11 +393,17 @@ let create ~contexts ~file_tree ~rules = |> Pmap.of_alist_multi |> Pmap.map ~f:Pset.of_list ) in - let t = { files = Hashtbl.create 1024; contexts } in + let t = + { contexts + ; files = Hashtbl.create 1024 + ; trace = Trace.load () + ; timestamps = Hashtbl.create 1024 + } in List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false); setup_copy_rules t ~all_targets_by_dir ~all_non_target_source_files: (Pset.diff all_source_files all_other_targets); + at_exit (fun () -> Trace.dump t.trace); t let remove_old_artifacts t = diff --git a/src/clflags.ml b/src/clflags.ml index 7dbb4d11..03f91a9f 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -2,6 +2,7 @@ let concurrency = ref 4 (*let ocaml_comp_flags = ref ["-g"]*) let g = ref true let debug_rules = ref false +let debug_actions = ref false let debug_run = ref true let debug_findlib = ref false let warnings = ref "-40" diff --git a/src/clflags.mli b/src/clflags.mli index ad610368..d7f8b698 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -12,6 +12,9 @@ val g : bool ref (** Print rules *) val debug_rules : bool ref +(** Print actions *) +val debug_actions : bool ref + (** Print executed commands *) val debug_run : bool ref diff --git a/src/context.mli b/src/context.mli index 33578fe6..5b1003d1 100644 --- a/src/context.mli +++ b/src/context.mli @@ -129,3 +129,5 @@ val opam_config_var : t -> string -> string option Future.t val install_prefix : t -> Path.t Future.t val env_for_exec : t -> string array + +val initial_env : string array Lazy.t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 12c094db..7d7f2eab 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -243,13 +243,8 @@ module Gen(P : Params) = struct let dst = Path.relative dir dst_fn in Build.path src >>> - Build.create_files ~targets:[dst] (fun () -> - let src_fn = Path.to_string src in - let dst_fn = Path.to_string dst in - with_file_in src_fn ~f:(fun ic -> - with_file_out dst_fn ~f:(fun oc -> - Printf.fprintf oc "# 1 \"%s\"\n" src_fn; - copy_channels ic oc)))) + Build.action ~targets:[dst] + (Copy_and_add_line_directive (src, dst))) (* Hides [t] so that we don't resolve things statically *) let t = () @@ -286,28 +281,28 @@ module Gen(P : Params) = struct [@@@warning "-32"] - let run ?(dir=ctx.build_dir) ?stdout_to ?(env=ctx.env) ?extra_targets prog args = - Build.run ~dir ?stdout_to ~env ?extra_targets prog args + let run ?(dir=ctx.build_dir) ?stdout_to ?extra_targets prog args = + Build.run ~dir ?stdout_to ~context:ctx ?extra_targets prog args - let run_capture ?(dir=ctx.build_dir) ?(env=ctx.env) prog args = - Build.run_capture ~dir ~env prog args - - let run_capture_lines ?(dir=ctx.build_dir) ?(env=ctx.env) prog args = - Build.run_capture_lines ~dir ~env prog args - - let bash ?dir ?stdout_to ?env ?extra_targets cmd = - run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?env ?extra_targets + let bash ?dir ?stdout_to ?extra_targets cmd = + run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?extra_targets [ As ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] ] - let system ?dir ?stdout_to ?env ?extra_targets cmd ~needed_to = + let system ?dir ?stdout_to ?extra_targets cmd ~needed_to = let path, arg, fail = Utils.system_shell ~needed_to in let build = - run (Dep path) ?dir ?stdout_to ?env ?extra_targets + run (Dep path) ?dir ?stdout_to ?extra_targets [ As [arg; cmd] ] in match fail with | None -> build | Some fail -> Build.fail fail >>> build + + let action ?dir ~targets action = + Build.action ?dir ~context:ctx ~targets action + + let action_context_independent ?dir ~targets shexp = + Build.action ?dir ~targets shexp end module Alias = struct @@ -512,9 +507,16 @@ module Gen(P : Params) = struct | Impl, _ -> S [A "-impl"; Dep fn] | Intf, _ -> S [A "-intf"; Dep fn]) in + let ocamldep_output = + Path.relative dir (sprintf "%s.depends%s.ocamldep-output" item suffix) + in add_rule - (Build.run_capture_lines (Dep ctx.ocamldep) [A "-modules"; S files] - >>^ parse_deps ~dir ~modules ~alias_module + (Build.run (Dep ctx.ocamldep) [A "-modules"; S files] ~stdout_to:ocamldep_output); + add_rule + (Build.path ocamldep_output + >>^ (fun () -> + parse_deps ~dir ~modules ~alias_module + (lines_of_file (Path.to_string ocamldep_output))) >>> Build.store_vfile vdepends); Build.vpath vdepends @@ -744,7 +746,7 @@ module Gen(P : Params) = struct |> List.map ~f:(Printf.sprintf "%s\n") |> String.concat ~sep:"") >>> - Build.echo path + Build.echo_dyn path ) | _ -> () @@ -977,8 +979,7 @@ module Gen(P : Params) = struct let mk_lib_cm_all (lib : Library.t) ~dir ~modules cm_kind = let deps = cm_files ~dir (String_map.values modules) ~cm_kind in add_rule (Build.paths deps >>> - Build.return "" >>> - Build.echo (lib_cm_all lib ~dir cm_kind)) + Build.create_file (lib_cm_all lib ~dir cm_kind)) let expand_includes ~dir includes = Arg_spec.As (List.concat_map includes ~f:(fun s -> @@ -1108,7 +1109,7 @@ module Gen(P : Params) = struct |> List.map ~f:(fun (m : Module.t) -> sprintf "module %s = %s\n" m.name (Module.real_unit_name m)) |> String.concat ~sep:"") - >>> Build.echo (Path.relative dir m.ml_fname))); + >>> Build.echo_dyn (Path.relative dir m.ml_fname))); let requires, real_requires = requires ~dir ~dep_kind ~item:lib.name @@ -1294,14 +1295,14 @@ module Gen(P : Params) = struct module Action_interpret : sig val run - : Action.Unexpanded.t + : Action.Mini_shexp.Unexpanded.t -> dir:Path.t -> dep_kind:Build.lib_dep_kind -> targets:Path.t list -> deps:Dep_conf.t list - -> (unit, unit) Build.t + -> (unit, Action.t) Build.t end = struct - module U = Action.Unexpanded + module U = Action.Mini_shexp.Unexpanded type resolved_forms = { (* Mapping from ${...} forms to their resolutions *) @@ -1337,7 +1338,7 @@ module Gen(P : Params) = struct ; lib_deps = String_set.empty } in - U.fold t ~init ~f:(fun acc var -> + U.fold_vars t ~init ~f:(fun acc var -> let module A = Artifacts in match String.lsplit2 var ~on:':' with | Some ("exe" , s) -> add_artifact acc ~var (Ok (Path.relative dir s)) @@ -1353,26 +1354,27 @@ module Gen(P : Params) = struct add_artifact acc ~var ~lib_dep res | _ -> acc) - let expand_string_with_vars ~artifacts ~targets ~deps = - let dep_exn ~dir name = function - | Some dep -> Path.reach ~from:dir dep + let expand_var = + let dep_exn name = function + | Some dep -> dep | None -> die "cannot use ${%s} with files_recursively_in" name in - let lookup ~dir var_name = + fun ~artifacts ~targets ~deps var_name -> match String_map.find var_name artifacts with - | Some path -> Some (Path.reach ~from:dir path) + | Some path -> Action.Path path | None -> match var_name with - | "@" -> Some (String.concat ~sep:" " - (List.map targets ~f:(Path.reach ~from:dir))) - | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn ~dir var_name dep1) + | "@" -> Paths targets + | "<" -> (match deps with + | [] -> Str "" + | dep1 :: _ -> Path (dep_exn var_name dep1)) | "^" -> - let deps = List.map deps ~f:(dep_exn ~dir var_name) in - Some (String.concat ~sep:" " deps) - | _ -> root_var_lookup ~dir var_name - in - fun ~dir str -> - String_with_vars.expand str ~f:(lookup ~dir) + Paths (List.map deps ~f:(dep_exn var_name)) + | "ROOT" -> Path Path.root + | _ -> + match String_map.find var_name dollar_var_map with + | Some s -> Str s + | _ -> Not_found let run t ~dir ~dep_kind ~targets ~deps = let deps = @@ -1381,6 +1383,10 @@ module Gen(P : Params) = struct ~f:(Path.relative dir)) in let forms = extract_artifacts ~dir t in + let t = + U.expand dir t + ~f:(expand_var ~artifacts:forms.artifacts ~targets ~deps) + in let build = Build.record_lib_deps ~dir ~kind:dep_kind (String_set.elements forms.lib_deps @@ -1388,8 +1394,7 @@ module Gen(P : Params) = struct >>> Build.paths (String_map.values forms.artifacts) >>> - Build.action t ~dir ~env:ctx.env ~targets - ~expand:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps) + Build.action t ~dir ~targets in match forms.failures with | [] -> build @@ -1419,29 +1424,31 @@ module Gen(P : Params) = struct let action = match alias_conf.action with | None -> Sexp.Atom "none" - | Some a -> List [Atom "some" ; Action.Unexpanded.sexp_of_t a] in + | Some a -> List [Atom "some" ; Action.Mini_shexp.Unexpanded.sexp_of_t a] in Sexp.List [deps ; action] |> Sexp.to_string |> Digest.string |> Digest.to_hex in let alias = Alias.make alias_conf.name ~dir in let digest_path = Path.extend_basename (Alias.file alias) ~suffix:("-" ^ digest) in - let dummy = Build.touch digest_path in Alias.add_deps alias [digest_path]; - let deps = - let deps = Dep_conf_interpret.dep_of_list ~dir alias_conf.deps in - match alias_conf.action with - | None -> deps - | Some action -> - deps - >>> Action_interpret.run - action - ~dir - ~dep_kind:Required - ~targets:[] - ~deps:alias_conf.deps - in - add_rule (deps >>> dummy) + let deps = Dep_conf_interpret.dep_of_list ~dir alias_conf.deps in + add_rule + (match alias_conf.action with + | None -> + deps + >>> + Build.create_file digest_path + | Some action -> + deps + >>> Action_interpret.run + action + ~dir + ~dep_kind:Required + ~targets:[] + ~deps:alias_conf.deps + >>> + Build.and_create_file digest_path) (* +-----------------------------------------------------------------+ | Modules listing | @@ -1516,7 +1523,7 @@ module Gen(P : Params) = struct List.iter stanzas ~f:(fun stanza -> let dir = ctx_dir in match (stanza : Stanza.t) with - | Rule rule -> user_rule rule ~dir + | Rule rule -> user_rule rule ~dir | Alias alias -> alias_rules alias ~dir | Library _ | Executables _ | Provides _ | Install _ -> ()); let files = lazy ( @@ -1644,22 +1651,24 @@ module Gen(P : Params) = struct in add_rule (Build.fanout meta template + >>^ (fun ((meta : Meta.t), template) -> + let buf = Buffer.create 1024 in + let ppf = Format.formatter_of_buffer buf in + Format.pp_open_vbox ppf 0; + List.iter template ~f:(fun s -> + if String.is_prefix s ~prefix:"#" then + match + String.split_words (String.sub s ~pos:1 ~len:(String.length s - 1)) + with + | ["JBUILDER_GEN"] -> Format.fprintf ppf "%a@," Meta.pp meta.entries + | _ -> Format.fprintf ppf "%s@," s + else + Format.fprintf ppf "%s@," s); + Format.pp_close_box ppf (); + Format.pp_print_flush ppf (); + Buffer.contents buf) >>> - Build.create_file ~target:meta_path (fun ((meta : Meta.t), template) -> - with_file_out (Path.to_string meta_path) ~f:(fun oc -> - let ppf = Format.formatter_of_out_channel oc in - Format.pp_open_vbox ppf 0; - List.iter template ~f:(fun s -> - if String.is_prefix s ~prefix:"#" then - match - String.split_words (String.sub s ~pos:1 ~len:(String.length s - 1)) - with - | ["JBUILDER_GEN"] -> Format.fprintf ppf "%a@," Meta.pp meta.entries - | _ -> Format.fprintf ppf "%s@," s - else - Format.fprintf ppf "%s@," s); - Format.pp_close_box ppf (); - Format.pp_print_flush ppf ()))); + Build.echo_dyn meta_path); if has_meta || has_meta_tmpl then Some pkg.name @@ -1780,9 +1789,11 @@ module Gen(P : Params) = struct in let entries = local_install_rules entries ~package in add_rule - (Build.path_set (Install.files entries) >>> - Build.create_file ~target:fn (fun () -> - Install.write_install_file fn entries)) + (Build.path_set (Install.files entries) + >>^ (fun () -> + Install.gen_install_file entries) + >>> + Build.echo_dyn fn) let () = String_map.iter P.packages ~f:(fun ~key:_ ~data:pkg -> install_file pkg.Package.path pkg.name) diff --git a/src/install.ml b/src/install.ml index 727a1ceb..f90c0585 100644 --- a/src/install.ml +++ b/src/install.ml @@ -119,14 +119,15 @@ let group entries = |> SMap.of_alist_multi |> SMap.bindings -let write_install_file file entries = - with_file_out (Path.to_string file) ~f:(fun oc -> - let pr fmt = Printf.fprintf oc (fmt ^^ "\n") in - List.iter (group entries) ~f:(fun (section, entries) -> - pr "%s: [" (Section.to_string section); +let gen_install_file entries = + let buf = Buffer.create 4096 in + let pr fmt = Printf.bprintf buf (fmt ^^ "\n") in + List.iter (group entries) ~f:(fun (section, entries) -> + pr "%s: [" (Section.to_string section); List.iter entries ~f:(fun (e : Entry.t) -> let src = Path.to_string e.src in match e.dst with | None -> pr " %S" src | Some dst -> pr " %S {%S}" src dst); - pr "]")) + pr "]"); + Buffer.contents buf diff --git a/src/install.mli b/src/install.mli index aa5272eb..84102daa 100644 --- a/src/install.mli +++ b/src/install.mli @@ -31,4 +31,4 @@ module Entry : sig end val files : Entry.t list -> Path.Set.t -val write_install_file : Path.t -> Entry.t list -> unit +val gen_install_file : Entry.t list -> string diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 78d844bf..c0a6f51e 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -546,13 +546,13 @@ module Rule = struct type t = { targets : string list (** List of files in the current directory *) ; deps : Dep_conf.t list - ; action : Action.Unexpanded.t + ; action : Action.Mini_shexp.Unexpanded.t } let common = field "targets" (list file_in_current_dir) >>= fun targets -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> - field "action" Action.Unexpanded.t >>= fun action -> + field "action" Action.Mini_shexp.Unexpanded.t >>= fun action -> return { targets; deps; action } let v1 = record common @@ -570,11 +570,10 @@ module Rule = struct { targets = [dst] ; deps = [File (str src)] ; action = - Shexp - (Chdir - (str "${ROOT}", - Run (str "${bin:ocamllex}", - [str "-q"; str "-o"; str "${@}"; str "${<}"]))) + Chdir + (str "${ROOT}", + Run (str "${bin:ocamllex}", + [str "-q"; str "-o"; str "${@}"; str "${<}"])) }) let ocamllex_vjs = ocamllex_v1 @@ -586,11 +585,10 @@ module Rule = struct { targets = [name ^ ".ml"; name ^ ".mli"] ; deps = [File (str src)] ; action = - Shexp - (Chdir - (str "${ROOT}", - Run (str "${bin:ocamlyacc}", - [str "${<}"]))) + Chdir + (str "${ROOT}", + Run (str "${bin:ocamlyacc}", + [str "${<}"])) }) let ocamlyacc_vjs = ocamlyacc_v1 @@ -660,13 +658,13 @@ module Alias_conf = struct type t = { name : string ; deps : Dep_conf.t list - ; action : Action.Unexpanded.t option + ; action : Action.Mini_shexp.Unexpanded.t option } let common = field "name" string >>= fun name -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> - field_o "action" Action.Unexpanded.t >>= fun action -> + field_o "action" Action.Mini_shexp.Unexpanded.t >>= fun action -> return { name ; deps diff --git a/src/path.ml b/src/path.ml index 2347140e..2fcf38ef 100644 --- a/src/path.ml +++ b/src/path.ml @@ -104,6 +104,51 @@ module Local = struct in loop initial_t (explode_path path) + let is_canonicalized = + let rec before_slash s i = + if i < 0 then + false + else + match s.[i] with + | '/' -> false + | '.' -> before_dot_slash s (i - 1) + | _ -> in_component s (i - 1) + and before_dot_slash s i = + if i < 0 then + false + else + match s.[i] with + | '/' -> false + | '.' -> before_dot_dot_slash s (i - 1) + | _ -> in_component s (i - 1) + and before_dot_dot_slash s i = + if i < 0 then + false + else + match s.[i] with + | '/' -> false + | _ -> in_component s (i - 1) + and in_component s i = + if i < 0 then + true + else + match s.[i] with + | '/' -> before_slash s (i - 1) + | _ -> in_component s (i - 1) + in + fun s -> + let len = String.length s in + if len = 0 then + true + else + before_slash s (len - 1) + + let of_string s = + if is_canonicalized s then + s + else + relative "" s + let rec mkdir_p = function | "" -> () | t -> @@ -176,8 +221,6 @@ let to_string = function | "" -> "." | t -> t -let sexp_of_t t = Sexp.Atom (to_string t) - let root = "" let relative t fn = @@ -189,7 +232,16 @@ let relative t fn = | _ , false -> fn | false, true -> External.relative t fn -let of_string t = relative "" t +let of_string = function + | "" -> "" + | s -> + if Filename.is_relative s then + Local.of_string s + else + s + +let t sexp = of_string (Sexp.Of_sexp.string sexp) +let sexp_of_t t = Sexp.Atom (to_string t) let absolute = let initial_dir = Sys.getcwd () in @@ -209,6 +261,21 @@ let reach t ~from = ] | true, true -> Local.reach t ~from +let reach_for_running t ~from = + match is_local t, is_local from with + | false, _ -> t + | true, false -> + Sexp.code_error "Path.reach_for_running called with invalid combination" + [ "t" , sexp_of_t t + ; "from", sexp_of_t from + ] + | true, true -> + let s = Local.reach t ~from in + if String.is_prefix s ~prefix:"../" then + s + else + "./" ^ s + let descendant t ~of_ = if is_local t && is_local of_ then Local.descendant t ~of_ @@ -270,3 +337,22 @@ let rmdir t = Unix.rmdir (to_string t) let unlink t = Unix.unlink (to_string t) let extend_basename t ~suffix = t ^ suffix + +let insert_after_build_dir_exn = + let error a b = + Sexp.code_error + "Path.insert_after_build_dir_exn" + [ "path" , Atom a + ; "insert", Atom b + ] + in + fun a b -> + if not (is_local a && is_local b) then error a b; + match String.lsplit2 a ~on:'/' with + | Some ("_build", rest) -> + if is_root b then + a + else + sprintf "_build/%s/%s" b rest + | _ -> + error a b diff --git a/src/path.mli b/src/path.mli index 7987285b..e29d354f 100644 --- a/src/path.mli +++ b/src/path.mli @@ -26,6 +26,9 @@ end type t +val t : t Sexp.Of_sexp.t +val sexp_of_t : t Sexp.To_sexp.t + val compare : t -> t -> int module Set : Set.S with type elt = t @@ -46,6 +49,7 @@ val relative : t -> string -> t val absolute : string -> t val reach : t -> from:t -> string +val reach_for_running : t -> from:t -> string val descendant : t -> of_:t -> t option @@ -60,6 +64,8 @@ val extract_build_context : t -> (string * t) option val extract_build_context_dir : t -> (t * t) option val is_in_build_dir : t -> bool +val insert_after_build_dir_exn : t -> t -> t + val exists : t -> bool val readdir : t -> string list val is_directory : t -> bool diff --git a/src/sexp.ml b/src/sexp.ml index cc3ccc6c..644b4548 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -60,6 +60,7 @@ module type Combinators = sig val bool : bool t val pair : 'a t -> 'b t -> ('a * 'b) t val list : 'a t -> 'a list t + val array : 'a t -> 'a array t val option : 'a t -> 'a option t val string_set : String_set.t t val string_map : 'a t -> 'a String_map.t t @@ -73,11 +74,14 @@ module To_sexp = struct let bool b = Atom (string_of_bool b) let pair fa fb (a, b) = List [fa a; fb b] let list f l = List (List.map l ~f) + let array f a = list f (Array.to_list a) let option f = function | None -> List [] | Some x -> List [f x] let string_set set = list string (String_set.elements set) let string_map f map = list (pair string f) (String_map.bindings map) + let record l = + List (List.map l ~f:(fun (n, v) -> List [Atom n; v])) end module Of_sexp = struct @@ -119,6 +123,8 @@ module Of_sexp = struct | Atom _ as sexp -> of_sexp_error sexp "List expected" | List (_, l) -> List.map l ~f + let array f sexp = Array.of_list (list f sexp) + let option f = function | List (_, []) -> None | List (_, [x]) -> Some (f x) diff --git a/src/sexp.mli b/src/sexp.mli index 459d8c03..973e379d 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -30,12 +30,18 @@ module type Combinators = sig val bool : bool t val pair : 'a t -> 'b t -> ('a * 'b) t val list : 'a t -> 'a list t + val array : 'a t -> 'a array t val option : 'a t -> 'a option t val string_set : String_set.t t val string_map : 'a t -> 'a String_map.t t end -module To_sexp : Combinators with type 'a t = 'a -> t +module To_sexp : sig + type sexp = t + include Combinators with type 'a t = 'a -> t + + val record : (string * sexp) list -> sexp +end with type sexp := t module Of_sexp : sig type ast = Ast.t = diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index c27f4e61..cee8e8eb 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -57,6 +57,12 @@ let of_string s = of_tokens (Token.tokenise s) let t sexp = of_string (Sexp.Of_sexp.string sexp) +let raw s = [Text s] + +let just_a_var = function + | [Var (_, s)] -> Some s + | _ -> None + let sexp_of_var_syntax = function | Parens -> Sexp.Atom "parens" | Braces -> Sexp.Atom "braces" @@ -88,25 +94,16 @@ let expand t ~f = | Parens -> sprintf "$(%s)" v | Braces -> sprintf "${%s}" v) |> String.concat ~sep:"" - -module type Container = sig - type 'a 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 map : 'a t -> f:('a -> 'b) -> 'b t - val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b -end - -module Lift(M : Container) = struct - type nonrec t = t M.t - let t sexp = M.t t sexp - - let sexp_of_t a = M.sexp_of_t sexp_of_t a - - let fold t ~init ~f = - M.fold t ~init ~f:(fun acc x -> fold x ~init:acc ~f) - - let expand t ~f = M.map t ~f:(expand ~f) -end - +(* +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:"" +*) diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index bff93f67..fb399c2a 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -10,29 +10,12 @@ val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t val of_string : string -> t +val raw : string -> t + +val just_a_var : t -> string option val vars : t -> String_set.t val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a val expand : t -> f:(string -> string option) -> string - -module type Container = sig - type 'a 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 map : 'a t -> f:('a -> 'b) -> 'b t - val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b -end - -module Lift(M : Container) : sig - type nonrec t = t M.t - val t : t Sexp.Of_sexp.t - - val sexp_of_t : t -> Sexp.t - - val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a - - val expand : t -> f:(string -> string option) -> string M.t -end diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index 1e0b97bc..3a3092c3 100644 --- a/src/vfile_kind.ml +++ b/src/vfile_kind.ml @@ -32,7 +32,7 @@ module type S = sig val id : t Id.t val load : Path.t -> t - val save : Path.t -> t -> unit + val to_string : Path.t -> t -> string end type 'a t = (module S with type t = 'a) @@ -52,11 +52,7 @@ struct let id = Id.create () - let save path x = - let s = To_sexp.t path x |> Sexp.to_string in - let oc = open_out (Path.to_string path) in - output_string oc s; - close_out oc + let to_string path x = To_sexp.t path x |> Sexp.to_string let load path = Of_sexp.t path (Sexp_load.single (Path.to_string path)) diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli index 4ee25ccf..447b910d 100644 --- a/src/vfile_kind.mli +++ b/src/vfile_kind.mli @@ -12,7 +12,7 @@ module type S = sig val id : t Id.t val load : Path.t -> t - val save : Path.t -> t -> unit + val to_string : Path.t -> t -> string end type 'a t = (module S with type t = 'a)