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

Merge branch 'incremental-build'

This commit is contained in:
Jérémie Dimino 2017-03-03 17:12:51 +00:00
parent 90c751566b c7a20aacc5
commit 05106744fb
27 changed files with 813 additions and 485 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CHANGES.org
View File

@ -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

12
bin/main.ml
View File

@ -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

33
doc/manual.org
View File

@ -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/<context>/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
=${<kind>:...}= 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 =${<kind>:...}= 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 <src> <dst>)= to copy a file and add a line directive at the beginning
- =(system <cmd>)= to execute a command using the system shell: =sh=
on Unix and =cmd= on Windows
- =(bash <cmd>)= to execute a command using =/bin/bash=. This is
obviously not very portable
Note: expansion of the special =${<kind>:...}= 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

389
src/action.ml
View File

@ -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)

55
src/action.mli Normal file
View File

@ -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

2
src/alias.ml
View File

@ -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)

13
src/ansi_color.ml
View File

@ -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

203
src/build.ml
View File

@ -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]
})

51
src/build.mli
View File

@ -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

8
src/build_interpret.ml
View File

@ -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
}

4
src/build_interpret.mli
View File

@ -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

122
src/build_system.ml
View File

@ -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 _ -> "<target to rule>")
@ -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 "@{<debug>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 =

1
src/clflags.ml
View File

@ -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"

3
src/clflags.mli
View File

@ -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

2
src/context.mli
View File

@ -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

171
src/gen_rules.ml
View File

@ -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)

13
src/install.ml
View File

@ -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

2
src/install.mli
View File

@ -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

26
src/jbuild_types.ml
View File

@ -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

92
src/path.ml
View File

@ -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

6
src/path.mli
View File

@ -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

6
src/sexp.ml
View File

@ -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)

8
src/sexp.mli
View File

@ -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 =

41
src/string_with_vars.ml
View File

@ -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:""
*)

23
src/string_with_vars.mli
View File

@ -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

8
src/vfile_kind.ml
View File

@ -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))

2
src/vfile_kind.mli
View File

@ -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)