[WIP] Load rules lazily (#370)
* Change jbuilder to load rules lazily Rules are now loaded on a per directory basis as needed. This speed up the start up time on large workspaces. Does various refactoring as well. * Simplify the handling of META files We no longer generate a META.foo.from-jbuilder file. Nobody is using this feature and it's making the new code more complicated.
This commit is contained in:
parent
1c8ca6718c
commit
9dd5ab74e4
|
@ -56,6 +56,15 @@ next
|
|||
ppx_driver. This allows to use `[@@deriving_inline]` in .ml/.mli
|
||||
files. This require `ppx_driver >= v0.10.2` to work properly (#415)
|
||||
|
||||
- Make jbuilder load rules lazily instead of generating them all
|
||||
eagerly. This speeds up the initial startup time of jbuilder on big
|
||||
workspaces (#370)
|
||||
|
||||
- Now longer generate a `META.pkg.from-jbuilder` file. Now the only
|
||||
way to customise the generated `META` file is through
|
||||
`META.pkg.template`. This feature was unused and was making the code
|
||||
complicated (#370)
|
||||
|
||||
1.0+beta16 (05/11/2017)
|
||||
-----------------------
|
||||
|
||||
|
|
105
bin/main.ml
105
bin/main.ml
|
@ -24,6 +24,7 @@ type common =
|
|||
; x : string option
|
||||
; diff_command : string option
|
||||
; auto_promote : bool
|
||||
; force : bool
|
||||
; (* Original arguments for the external-lib-deps hint *)
|
||||
orig_args : string list
|
||||
}
|
||||
|
@ -43,6 +44,7 @@ let set_common c ~targets =
|
|||
Clflags.workspace_root := Sys.getcwd ();
|
||||
Clflags.diff_command := c.diff_command;
|
||||
Clflags.auto_promote := c.auto_promote;
|
||||
Clflags.force := c.force;
|
||||
Clflags.external_lib_deps_hint :=
|
||||
List.concat
|
||||
[ ["jbuilder"; "external-lib-deps"; "--missing"]
|
||||
|
@ -73,10 +75,9 @@ let restore_cwd_and_execve common prog argv env =
|
|||
module Main = struct
|
||||
include Jbuilder.Main
|
||||
|
||||
let setup ~log ?unlink_aliases ?filter_out_optional_stanzas_with_missing_deps common =
|
||||
let setup ~log ?filter_out_optional_stanzas_with_missing_deps common =
|
||||
setup
|
||||
~log
|
||||
?unlink_aliases
|
||||
?workspace_file:common.workspace_file
|
||||
?only_packages:common.only_packages
|
||||
?filter_out_optional_stanzas_with_missing_deps
|
||||
|
@ -86,17 +87,29 @@ end
|
|||
|
||||
type target =
|
||||
| File of Path.t
|
||||
| Alias_rec of Alias.t
|
||||
| Alias_rec of Path.t
|
||||
|
||||
let request_of_targets (setup : Main.setup) targets =
|
||||
let open Build.O in
|
||||
let contexts = List.map setup.contexts ~f:(fun c -> c.Context.name) in
|
||||
List.fold_left targets ~init:(Build.return ()) ~f:(fun acc target ->
|
||||
acc >>>
|
||||
match target with
|
||||
| File path -> Build.path path
|
||||
| Alias_rec alias ->
|
||||
Alias.dep_rec ~loc:(Loc.in_file "<command-line>")
|
||||
~file_tree:setup.file_tree alias)
|
||||
| Alias_rec path ->
|
||||
let dir = Path.parent path in
|
||||
let name = Path.basename path in
|
||||
let contexts, dir =
|
||||
match Path.extract_build_context dir with
|
||||
| None -> (contexts, dir)
|
||||
| Some ("install", _) ->
|
||||
die "Invalid alias: %s.\n\
|
||||
There are no aliases in _build/install."
|
||||
(Path.to_string_maybe_quoted path)
|
||||
| Some (ctx, dir) -> ([ctx], dir)
|
||||
in
|
||||
Build_system.Alias.dep_rec_multi_contexts ~dir ~name
|
||||
~file_tree:setup.file_tree ~contexts)
|
||||
|
||||
let do_build (setup : Main.setup) targets =
|
||||
Build_system.do_build_exn setup.build_system
|
||||
|
@ -162,6 +175,7 @@ let common =
|
|||
workspace_file
|
||||
diff_command
|
||||
auto_promote
|
||||
force
|
||||
(root, only_packages, orig)
|
||||
x
|
||||
=
|
||||
|
@ -190,6 +204,7 @@ let common =
|
|||
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
||||
; diff_command
|
||||
; auto_promote
|
||||
; force
|
||||
; only_packages =
|
||||
Option.map only_packages
|
||||
~f:(fun s -> String_set.of_list (String.split s ~on:','))
|
||||
|
@ -287,6 +302,13 @@ let common =
|
|||
~doc:"Automatically promote files. This is similar to running
|
||||
$(b,jbuilder promote) after the build.")
|
||||
in
|
||||
let force =
|
||||
Arg.(value
|
||||
& flag
|
||||
& info ["force"; "f"]
|
||||
~doc:"Force actions associated to aliases to be re-executed even
|
||||
if their dependencies haven't changed.")
|
||||
in
|
||||
let for_release = "for-release-of-packages" in
|
||||
let frop =
|
||||
Arg.(value
|
||||
|
@ -349,6 +371,7 @@ let common =
|
|||
$ workspace_file
|
||||
$ diff_command
|
||||
$ auto_promote
|
||||
$ force
|
||||
$ root_and_only_packages
|
||||
$ x
|
||||
)
|
||||
|
@ -423,21 +446,43 @@ let target_hint (setup : Main.setup) path =
|
|||
let candidates = String_set.of_list candidates |> String_set.elements in
|
||||
hint (Path.to_string path) candidates
|
||||
|
||||
let check_path contexts =
|
||||
let contexts = String_set.of_list (List.map contexts ~f:(fun c -> c.Context.name)) in
|
||||
fun path ->
|
||||
let internal path =
|
||||
die "This path is internal to jbuilder: %s" (Path.to_string_maybe_quoted path)
|
||||
in
|
||||
if Path.is_in_build_dir path then
|
||||
match Path.extract_build_context path with
|
||||
| None -> internal path
|
||||
| Some (name, _) ->
|
||||
if name = "" || name.[0] = '.' then internal path;
|
||||
if not (name = "install" || String_set.mem name contexts) then
|
||||
die "%s refers to unknown build context: %s%s"
|
||||
(Path.to_string_maybe_quoted path)
|
||||
name
|
||||
(hint name (String_set.elements contexts))
|
||||
|
||||
let resolve_targets ~log common (setup : Main.setup) user_targets =
|
||||
match user_targets with
|
||||
| [] -> []
|
||||
| _ ->
|
||||
let check_path = check_path setup.contexts in
|
||||
let targets =
|
||||
List.map user_targets ~f:(fun s ->
|
||||
if String.is_prefix s ~prefix:"@" then
|
||||
if String.is_prefix s ~prefix:"@" then begin
|
||||
let s = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
||||
let path = Path.relative Path.root (prefix_target common s) in
|
||||
check_path path;
|
||||
if Path.is_root path then
|
||||
die "@@ on the command line must be followed by a valid alias name"
|
||||
else if not (Path.is_local path) then
|
||||
die "@@ on the command line must be followed by a relative path"
|
||||
else
|
||||
Ok [Alias_rec (Alias.of_path path)]
|
||||
else
|
||||
Ok [Alias_rec path]
|
||||
end else begin
|
||||
let path = Path.relative Path.root (prefix_target common s) in
|
||||
check_path path;
|
||||
let can't_build path =
|
||||
Error (path, target_hint setup path);
|
||||
in
|
||||
|
@ -450,23 +495,17 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
|
|||
can't_build path
|
||||
end else
|
||||
match
|
||||
let l =
|
||||
List.filter_map setup.contexts ~f:(fun ctx ->
|
||||
let path = Path.append ctx.Context.build_dir path in
|
||||
if Build_system.is_target setup.build_system path then
|
||||
Some (File path)
|
||||
else
|
||||
None)
|
||||
in
|
||||
if Build_system.is_target setup.build_system path ||
|
||||
Path.exists path then
|
||||
File path :: l
|
||||
else
|
||||
l
|
||||
List.filter_map setup.contexts ~f:(fun ctx ->
|
||||
let path = Path.append ctx.Context.build_dir path in
|
||||
if Build_system.is_target setup.build_system path then
|
||||
Some (File path)
|
||||
else
|
||||
None)
|
||||
with
|
||||
| [] -> can't_build path
|
||||
| l -> Ok l
|
||||
)
|
||||
end
|
||||
)
|
||||
in
|
||||
if !Clflags.verbose then begin
|
||||
Log.info log "Actual targets:";
|
||||
|
@ -477,8 +516,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
|
|||
List.iter targets ~f:(function
|
||||
| File path ->
|
||||
Log.info log @@ "- " ^ (Path.to_string path)
|
||||
| Alias_rec alias ->
|
||||
let path = Alias.fully_qualified_name alias in
|
||||
| Alias_rec path ->
|
||||
Log.info log @@ "- recursive alias " ^
|
||||
(Path.to_string_maybe_quoted path));
|
||||
flush stdout;
|
||||
|
@ -524,8 +562,7 @@ let runtest =
|
|||
]
|
||||
in
|
||||
let name_ = Arg.info [] ~docv:"DIR" in
|
||||
let go common force dirs =
|
||||
let unlink_aliases = if force then Some ["runtest"] else None in
|
||||
let go common dirs =
|
||||
set_common common
|
||||
~targets:(List.map dirs ~f:(function
|
||||
| "" | "." -> "@runtest"
|
||||
|
@ -533,16 +570,17 @@ let runtest =
|
|||
| dir -> sprintf "@%s/runtest" dir));
|
||||
let log = Log.create () in
|
||||
Future.Scheduler.go ~log
|
||||
(Main.setup ?unlink_aliases ~log common >>= fun setup ->
|
||||
(Main.setup ~log common >>= fun setup ->
|
||||
let check_path = check_path setup.contexts in
|
||||
let targets =
|
||||
List.map dirs ~f:(fun dir ->
|
||||
let dir = Path.(relative root) (prefix_target common dir) in
|
||||
Alias_rec (Alias.runtest ~dir))
|
||||
check_path dir;
|
||||
Alias_rec (Path.relative dir "runtest"))
|
||||
in
|
||||
do_build setup targets) in
|
||||
( Term.(const go
|
||||
$ common
|
||||
$ Arg.(value & flag & info ["force"; "f"])
|
||||
$ Arg.(value & pos_all string ["."] name_))
|
||||
, Term.info "runtest" ~doc ~man)
|
||||
|
||||
|
@ -557,7 +595,8 @@ let clean =
|
|||
let go common =
|
||||
begin
|
||||
set_common common ~targets:[];
|
||||
Build_system.all_targets_ever_built () |> List.iter ~f:Path.unlink_no_err;
|
||||
Build_system.files_in_source_tree_to_delete ()
|
||||
|> List.iter ~f:Path.unlink_no_err;
|
||||
Path.(rm_rf (append root (of_string "_build")))
|
||||
end
|
||||
in
|
||||
|
@ -928,7 +967,7 @@ let exec =
|
|||
| [] -> ()
|
||||
| targets ->
|
||||
Future.Scheduler.go ~log (do_build setup targets);
|
||||
Build_system.dump_trace setup.build_system
|
||||
Build_system.finalize setup.build_system
|
||||
end;
|
||||
match prog_where with
|
||||
| `Search prog ->
|
||||
|
@ -1061,7 +1100,7 @@ let utop =
|
|||
do_build setup [File target] >>| fun () ->
|
||||
(setup.build_system, context, Path.to_string target)
|
||||
) |> Future.Scheduler.go ~log in
|
||||
Build_system.dump_trace build_system;
|
||||
Build_system.finalize build_system;
|
||||
restore_cwd_and_execve common utop_path (Array.of_list (utop_path :: args))
|
||||
(Context.env_for_exec context)
|
||||
in
|
||||
|
|
|
@ -16,26 +16,19 @@ of a project to Jbuilder, it is allowed to write/generate a specific
|
|||
one.
|
||||
|
||||
In order to do that, write or setup a rule to generate a
|
||||
``META.<package>`` file in the same directory as the ``<package>.opam``
|
||||
file. If you do that, Jbuilder will still generate a ``META`` file but
|
||||
it will be called ``META.<package>.from-jbuilder``. So for instance if
|
||||
you want to extend the ``META`` file generated by Jbuilder you can
|
||||
write:
|
||||
``META.<package>.template`` file in the same directory as the
|
||||
``<package>.opam`` file. Jbuilder will generate a ``META.<package>``
|
||||
file from the ``META.<package>.template`` file by replacing lines of
|
||||
the form ``# JBUILDER_GEN`` by the contents of the ``META`` it would
|
||||
normally generate.
|
||||
|
||||
.. code:: scheme
|
||||
For instance if you want to extend the ``META`` file generated by
|
||||
Jbuilder you can write the folliwing ``META.foo.template`` file:
|
||||
|
||||
(rule
|
||||
((targets (META.foo))
|
||||
(deps (META.foo.from-jbuilder))
|
||||
(action (with-stdout-to ${@}
|
||||
(progn
|
||||
(cat ${<})
|
||||
(echo blah))))))
|
||||
.. code::
|
||||
|
||||
Additionally, Jbuilder provides a simpler mechanism for this scheme:
|
||||
just write or generate a ``META.<package>.template`` file containing a
|
||||
line of the form ``# JBUILDER_GEN``. Jbuilder will automatically insert
|
||||
its generated ``META`` contents in place of this line.
|
||||
# JBUILDER_GEN
|
||||
blah = "..."
|
||||
|
||||
.. _custom-driver:
|
||||
|
||||
|
|
|
@ -91,14 +91,13 @@ the command line.
|
|||
Resolution
|
||||
----------
|
||||
|
||||
Most targets that Jbuilder knows how to build lives in the ``_build`` directory,
|
||||
except for a few:
|
||||
All targets that Jbuilder knows how to build live in the ``_build``
|
||||
directory. Although, some are sometimes copied to the source tree for
|
||||
the need of external tools. These includes:
|
||||
|
||||
= ``.merlin`` files
|
||||
- ``.merlin`` files
|
||||
|
||||
- ``<package>.install`` files; for the ``default`` context Jbuilder knows how
|
||||
generate the install file both in ``_build/default`` and in the source tree
|
||||
so that ``opam`` can find it
|
||||
- ``<package>.install`` files
|
||||
|
||||
As a result, if you want to ask ``jbuilder`` to produce a particular ``.exe``
|
||||
file you would have to type:
|
||||
|
@ -107,14 +106,15 @@ file you would have to type:
|
|||
|
||||
$ jbuilder build _build/default/bin/prog.exe
|
||||
|
||||
However, for convenience when a target on the command line doesn't start with
|
||||
``_build``, ``jbuilder`` will expand it to the corresponding target in all the
|
||||
build contexts where it knows how to build it. It prints out the actual set of
|
||||
targets when starting so that you know what is happening:
|
||||
However, for convenience when a target on the command line doesn't
|
||||
start with ``_build``, ``jbuilder`` will expand it to the
|
||||
corresponding target in all the build contexts where it knows how to
|
||||
build it. When using ``--verbose``, It prints out the actual set of
|
||||
targets when starting:
|
||||
|
||||
.. code:: bash
|
||||
|
||||
$ jbuilder build bin/prog.exe
|
||||
$ jbuilder build bin/prog.exe --verbose
|
||||
...
|
||||
Actual targets:
|
||||
- _build/default/bin/prog.exe
|
||||
|
@ -126,11 +126,11 @@ Aliases
|
|||
|
||||
Targets starting with a ``@`` are interpreted as aliases. For instance
|
||||
``@src/runtest`` means the alias ``runtest`` in all descendant of
|
||||
``src`` where it is defined. If you want to refer to a target starting
|
||||
with a ``@``, simply write: ``./@foo``.
|
||||
``src`` in all build contexts where it is defined. If you want to
|
||||
refer to a target starting with a ``@``, simply write: ``./@foo``.
|
||||
|
||||
Note that an alias not pointing to the ``_build`` directory always
|
||||
depends on all the corresponding aliases in build contexts.
|
||||
To build and run the tests for a particular build context, use
|
||||
``@_build/default/runtest`` instead.
|
||||
|
||||
So for instance:
|
||||
|
||||
|
|
|
@ -795,7 +795,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
|
|||
exec_echo stdout_to s
|
||||
| Diff { optional; file1; file2 } ->
|
||||
if (optional && not (Path.exists file1 && Path.exists file2)) ||
|
||||
Io.read_file (Path.to_string file1) = Io.read_file (Path.to_string file2) then
|
||||
Io.compare_files (Path.to_string file1) (Path.to_string file2) = 0 then
|
||||
return ()
|
||||
else begin
|
||||
let is_copied_from_source_tree file =
|
||||
|
|
210
src/alias.ml
210
src/alias.ml
|
@ -1,210 +0,0 @@
|
|||
open! Import
|
||||
|
||||
(** Fully qualified name *)
|
||||
module Fq_name : sig
|
||||
type t
|
||||
val pp : Format.formatter -> t -> unit
|
||||
val make : Path.t -> t
|
||||
val path : t -> Path.t
|
||||
end = struct
|
||||
type t = Path.t
|
||||
let make t = t
|
||||
let path t = t
|
||||
let pp = Path.pp
|
||||
end
|
||||
|
||||
type t =
|
||||
{ name : Fq_name.t
|
||||
; file : Path.t
|
||||
}
|
||||
|
||||
let pp fmt t =
|
||||
Format.fprintf fmt "@[<2>{ name@ =@ %a@ ;@ file@ =@ %a }@]"
|
||||
Path.pp (Fq_name.path t.name) Path.pp t.file
|
||||
|
||||
let aliases_path = Path.(relative root) "_build/.aliases"
|
||||
|
||||
let suffix = "-" ^ String.make 32 '0'
|
||||
|
||||
let of_path path =
|
||||
if not (Path.is_local path) then
|
||||
die "Aliases are only supported for local paths!\n\
|
||||
Tried to reference alias %S"
|
||||
(Path.to_string path);
|
||||
{ name = Fq_name.make path
|
||||
; file = Path.extend_basename (Path.append aliases_path path) ~suffix
|
||||
}
|
||||
|
||||
let name t = Path.basename (Fq_name.path t.name)
|
||||
let dir t = Path.parent (Fq_name.path t.name)
|
||||
|
||||
let fully_qualified_name t = Fq_name.path t.name
|
||||
|
||||
let make name ~dir =
|
||||
assert (not (String.contains name '/'));
|
||||
of_path (Path.relative dir name)
|
||||
|
||||
let dep t = Build.path t.file
|
||||
|
||||
let is_standard = function
|
||||
| "runtest" | "install" | "doc" | "lint" -> true
|
||||
| _ -> false
|
||||
|
||||
let dep_rec ~loc ~file_tree t =
|
||||
let path = Path.parent (Fq_name.path t.name) |> Path.drop_optional_build_context in
|
||||
let name = Path.basename (Fq_name.path t.name) in
|
||||
match File_tree.find_dir file_tree path with
|
||||
| None -> Build.fail { fail = fun () ->
|
||||
Loc.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted path) }
|
||||
| Some dir ->
|
||||
let open Build.O in
|
||||
File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true)
|
||||
~f:(fun dir acc ->
|
||||
let path = File_tree.Dir.path dir in
|
||||
let t = of_path (Path.relative path name) in
|
||||
acc
|
||||
>>>
|
||||
Build.if_file_exists t.file
|
||||
~then_:(Build.path t.file
|
||||
>>^
|
||||
fun _ -> false)
|
||||
~else_:(Build.arr (fun x -> x)))
|
||||
>>^ fun is_empty ->
|
||||
if is_empty && not (is_standard name) then
|
||||
Loc.fail loc "This alias is empty.\n\
|
||||
Alias %S is not defined in %s or any of its descendants."
|
||||
name (Path.to_string_maybe_quoted path)
|
||||
|
||||
let file t = t.file
|
||||
|
||||
let file_with_digest_suffix t ~digest =
|
||||
let dir = Path.parent t.file in
|
||||
let base = Path.basename t.file in
|
||||
let len = String.length base in
|
||||
Path.relative dir
|
||||
(String.sub base ~pos:0 ~len:(len - 32) ^ Digest.to_hex digest)
|
||||
|
||||
let of_file fn =
|
||||
match Path.extract_build_context fn with
|
||||
| Some (".aliases", fn) -> begin
|
||||
let dir = Path.parent fn in
|
||||
let name = Path.basename fn in
|
||||
match String.rsplit2 name ~on:'-' with
|
||||
| None -> assert false
|
||||
| Some (name, digest) ->
|
||||
assert (String.length digest = 32);
|
||||
Some (make name ~dir)
|
||||
end
|
||||
| _ -> None
|
||||
|
||||
let name_of_file fn =
|
||||
match Path.extract_build_context fn with
|
||||
| Some (".aliases", fn) -> begin
|
||||
let name = Path.basename fn in
|
||||
match String.rsplit2 name ~on:'-' with
|
||||
| None -> assert false
|
||||
| Some (name, digest) ->
|
||||
assert (String.length digest = 32);
|
||||
Some name
|
||||
end
|
||||
| _ -> None
|
||||
|
||||
let default = make "DEFAULT"
|
||||
let runtest = make "runtest"
|
||||
let install = make "install"
|
||||
let doc = make "doc"
|
||||
let lint = make "lint"
|
||||
|
||||
module Store = struct
|
||||
type entry =
|
||||
{ alias : t
|
||||
; mutable deps : Path.Set.t
|
||||
}
|
||||
let pp_entry fmt entry =
|
||||
let pp_deps fmt deps =
|
||||
Format.pp_print_list Path.pp fmt (Path.Set.elements deps) in
|
||||
Format.fprintf fmt "@[<2>{@ alias@ =@ %a@ ;@ deps@ = (%a)@ }@]"
|
||||
pp entry.alias pp_deps entry.deps
|
||||
|
||||
type t = (Fq_name.t, entry) Hashtbl.t
|
||||
|
||||
let pp fmt (t : t) =
|
||||
let bindings = Hashtbl.fold ~init:[] ~f:(fun ~key ~data acc ->
|
||||
(key, data)::acc
|
||||
) t in
|
||||
let pp_bindings fmt b =
|
||||
Format.pp_print_list (fun fmt (k, v) ->
|
||||
Format.fprintf fmt "@[<2>(%a@ %a)@]" Fq_name.pp k pp_entry v
|
||||
) fmt b in
|
||||
Format.fprintf fmt "Store.t@ @[@<2>(%a)@]" pp_bindings bindings
|
||||
|
||||
let create () = Hashtbl.create 1024
|
||||
|
||||
let unlink (store : t) = function
|
||||
| [] -> ()
|
||||
| alias_basenames ->
|
||||
store
|
||||
|> Hashtbl.fold ~init:Path.Set.empty ~f:(fun ~key:_ ~data:entry acc ->
|
||||
if List.mem (name entry.alias) ~set:alias_basenames then (
|
||||
Path.Set.union acc (Path.Set.add entry.alias.file entry.deps)
|
||||
) else (
|
||||
acc
|
||||
))
|
||||
|> Path.Set.iter ~f:Path.unlink_no_err
|
||||
end
|
||||
|
||||
let add_deps store t deps =
|
||||
let deps = Path.Set.of_list deps in
|
||||
match Hashtbl.find store t.name with
|
||||
| None ->
|
||||
Hashtbl.add store ~key:t.name
|
||||
~data:{ Store.alias = t
|
||||
; deps = deps
|
||||
}
|
||||
| Some e -> e.deps <- Path.Set.union deps e.deps
|
||||
|
||||
let rules store =
|
||||
(* For each alias @_build/blah/../x, add a dependency: @../x --> @_build/blah/../x *)
|
||||
Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; _ } acc ->
|
||||
match Path.extract_build_context (Fq_name.path alias.name) with
|
||||
| None -> acc
|
||||
| Some (_, in_src) -> (of_path in_src, alias) :: acc)
|
||||
|> List.iter ~f:(fun (in_src, in_build_dir) ->
|
||||
add_deps store in_src [in_build_dir.file]);
|
||||
|
||||
Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; deps } acc ->
|
||||
let open Build.O in
|
||||
let rule =
|
||||
Build_interpret.Rule.make
|
||||
(Build.path_set deps >>>
|
||||
Build.action ~targets:[alias.file]
|
||||
(Redirect (Stdout,
|
||||
alias.file,
|
||||
Digest_files
|
||||
(Path.Set.elements deps))))
|
||||
in
|
||||
rule :: acc)
|
||||
|
||||
let add_build store t ~stamp build =
|
||||
let digest = Digest.string (Sexp.to_string stamp) in
|
||||
let digest_path = file_with_digest_suffix t ~digest in
|
||||
add_deps store t [digest_path];
|
||||
Build.progn
|
||||
[ build
|
||||
; Build.create_file digest_path
|
||||
]
|
||||
|
||||
let add_builds store t builds =
|
||||
let digest_files, actions =
|
||||
List.split
|
||||
(List.map builds ~f:(fun (stamp, build) ->
|
||||
let digest = Digest.string (Sexp.to_string stamp) in
|
||||
let digest_path = file_with_digest_suffix t ~digest in
|
||||
(digest_path,
|
||||
Build.progn
|
||||
[ build
|
||||
; Build.create_file digest_path
|
||||
])))
|
||||
in
|
||||
add_deps store t digest_files;
|
||||
actions
|
|
@ -1,95 +0,0 @@
|
|||
(** Rule aliases. *)
|
||||
|
||||
open Import
|
||||
|
||||
|
||||
type t
|
||||
|
||||
val pp : t Fmt.t
|
||||
|
||||
val make : string -> dir:Path.t -> t
|
||||
|
||||
val of_path : Path.t -> t
|
||||
|
||||
(** The following always holds:
|
||||
|
||||
{[
|
||||
make (name t) ~dir:(dir t) = t
|
||||
]}
|
||||
*)
|
||||
val name : t -> string
|
||||
val dir : t -> Path.t
|
||||
|
||||
val fully_qualified_name : t -> Path.t
|
||||
|
||||
val default : dir:Path.t -> t
|
||||
val runtest : dir:Path.t -> t
|
||||
val install : dir:Path.t -> t
|
||||
val doc : dir:Path.t -> t
|
||||
val lint : dir:Path.t -> t
|
||||
|
||||
val dep : t -> ('a, 'a) Build.t
|
||||
|
||||
(** Implements [(alias_rec ...)] in dependency specification and
|
||||
[@alias] on the command line. *)
|
||||
val dep_rec : loc:Loc.t -> file_tree:File_tree.t -> t -> (unit, unit) Build.t
|
||||
|
||||
(** File that represent the alias in the filesystem. It is a file under
|
||||
[_build/.aliases]. *)
|
||||
val file : t -> Path.t
|
||||
|
||||
(** Same as [file t], except that it sets the digest suffix to [digest]. Files
|
||||
representing aliases ends with a hex-encoded md5sum of some data. It is usually filled
|
||||
with zeros except for files that represent the running of an action associated to an
|
||||
alias, it which case it is the md5 checksum of the action and its dependencies. *)
|
||||
val file_with_digest_suffix : t -> digest:Digest.t -> Path.t
|
||||
|
||||
(** The following holds for any path [p]:
|
||||
|
||||
{[
|
||||
match of_file p with
|
||||
| None -> true
|
||||
| Some t -> p = file t
|
||||
]}
|
||||
*)
|
||||
val of_file : Path.t -> t option
|
||||
|
||||
(** Same as [Option.map (of_file p) ~f:name] but more efficient. *)
|
||||
val name_of_file : Path.t -> string option
|
||||
|
||||
module Store : sig
|
||||
type t
|
||||
|
||||
val pp : t Fmt.t
|
||||
|
||||
val create : unit -> t
|
||||
|
||||
val unlink : t -> string list -> unit
|
||||
end
|
||||
|
||||
(** [add_build store alias deps] arrange things so that all [deps] are built as part of
|
||||
the build of alias [alias]. *)
|
||||
val add_deps : Store.t -> t -> Path.t list -> unit
|
||||
|
||||
(** [add_build store alias ~stamp build] arrange things so that [build] is part of the
|
||||
build of alias [alias]. [stamp] is any S-expression that is unique and persistent
|
||||
S-expression.
|
||||
|
||||
Return a rule that must be added with [Super_context.add_rule].
|
||||
*)
|
||||
val add_build
|
||||
: Store.t
|
||||
-> t
|
||||
-> stamp:Sexp.t
|
||||
-> (unit, Action.t) Build.t
|
||||
-> (unit, Action.t) Build.t
|
||||
|
||||
(** Same as calling [add_build] in a loop but slightly more efficient. *)
|
||||
val add_builds
|
||||
: Store.t
|
||||
-> t
|
||||
-> (Sexp.t * (unit, Action.t) Build.t) list
|
||||
-> (unit, Action.t) Build.t list
|
||||
|
||||
val rules : Store.t -> Build_interpret.Rule.t list
|
||||
|
|
@ -26,7 +26,7 @@ module Static_deps = struct
|
|||
}
|
||||
end
|
||||
|
||||
let static_deps t ~all_targets_by_dir =
|
||||
let static_deps t ~all_targets =
|
||||
let rec loop : type a b. (a, b) t -> Static_deps.t -> Static_deps.t = fun t acc ->
|
||||
match t with
|
||||
| Arr _ -> acc
|
||||
|
@ -43,30 +43,32 @@ let static_deps t ~all_targets_by_dir =
|
|||
| G_evaluated l ->
|
||||
{ acc with action_deps = Pset.union acc.action_deps (Pset.of_list l) }
|
||||
| G_unevaluated (loc, dir, re) ->
|
||||
match Pmap.find dir (Lazy.force all_targets_by_dir) with
|
||||
| None ->
|
||||
Loc.warn loc "Directory %s doesn't exist."
|
||||
(Path.to_string_maybe_quoted dir);
|
||||
state := G_evaluated [];
|
||||
acc
|
||||
| Some targets ->
|
||||
let result =
|
||||
Pset.filter targets ~f:(fun path ->
|
||||
Re.execp re (Path.basename path))
|
||||
in
|
||||
state := G_evaluated (Pset.elements result);
|
||||
let action_deps = Pset.union result acc.action_deps in
|
||||
{ acc with action_deps }
|
||||
let targets = all_targets ~dir in
|
||||
let result =
|
||||
Pset.filter targets ~f:(fun path ->
|
||||
Re.execp re (Path.basename path))
|
||||
in
|
||||
if Pset.is_empty result then begin
|
||||
if not (Path.exists dir) then
|
||||
Loc.warn loc "Directory %s doesn't exist."
|
||||
(Path.to_string_maybe_quoted dir)
|
||||
else if not (Path.is_directory dir) then
|
||||
Loc.warn loc "%s is not a directory."
|
||||
(Path.to_string_maybe_quoted dir)
|
||||
else
|
||||
(* diml: we should probably warn in this case as well *)
|
||||
()
|
||||
end;
|
||||
state := G_evaluated (Pset.elements result);
|
||||
let action_deps = Pset.union result acc.action_deps in
|
||||
{ acc with action_deps }
|
||||
end
|
||||
| If_file_exists (p, state) -> begin
|
||||
match !state with
|
||||
| Decided (_, t) -> loop t acc
|
||||
| Undecided (then_, else_) ->
|
||||
let dir = Path.parent p in
|
||||
let targets =
|
||||
Option.value (Pmap.find dir (Lazy.force all_targets_by_dir))
|
||||
~default:Pset.empty
|
||||
in
|
||||
let targets = all_targets ~dir in
|
||||
if Pset.mem p targets then begin
|
||||
state := Decided (true, then_);
|
||||
loop then_ acc
|
||||
|
@ -157,19 +159,38 @@ module Rule = struct
|
|||
; build : (unit, Action.t) Build.t
|
||||
; targets : Target.t list
|
||||
; sandbox : bool
|
||||
; fallback : Jbuild.Rule.Fallback.t
|
||||
; mode : Jbuild.Rule.Mode.t
|
||||
; locks : Path.t list
|
||||
; loc : Loc.t option
|
||||
; dir : Path.t
|
||||
}
|
||||
|
||||
let make ?(sandbox=false) ?(fallback=Jbuild.Rule.Fallback.Not_possible)
|
||||
let make ?(sandbox=false) ?(mode=Jbuild.Rule.Mode.Not_a_rule_stanza)
|
||||
?context ?(locks=[]) ?loc build =
|
||||
let targets = targets build in
|
||||
let dir =
|
||||
match targets with
|
||||
| [] ->
|
||||
invalid_arg "Build_interpret.Rule.make: rule has no targets"
|
||||
| x :: l ->
|
||||
let dir = Path.parent (Target.path x) in
|
||||
List.iter l ~f:(fun target ->
|
||||
let path = Target.path target in
|
||||
if Path.parent path <> dir then
|
||||
Sexp.code_error "rule has targets in different directories"
|
||||
[ "dir", Path.sexp_of_t dir
|
||||
; "targets", Sexp.To_sexp.list Path.sexp_of_t
|
||||
(List.map (x :: l) ~f:Target.path)
|
||||
]);
|
||||
dir
|
||||
in
|
||||
{ context
|
||||
; build
|
||||
; targets = targets build
|
||||
; targets
|
||||
; sandbox
|
||||
; fallback
|
||||
; mode
|
||||
; locks
|
||||
; loc
|
||||
; dir
|
||||
}
|
||||
end
|
||||
|
|
|
@ -15,14 +15,16 @@ module Rule : sig
|
|||
; build : (unit, Action.t) Build.t
|
||||
; targets : Target.t list
|
||||
; sandbox : bool
|
||||
; fallback : Jbuild.Rule.Fallback.t
|
||||
; mode : Jbuild.Rule.Mode.t
|
||||
; locks : Path.t list
|
||||
; loc : Loc.t option
|
||||
; (** Directory where all the targets are produced *)
|
||||
dir : Path.t
|
||||
}
|
||||
|
||||
val make
|
||||
: ?sandbox:bool
|
||||
-> ?fallback:Jbuild.Rule.Fallback.t
|
||||
-> ?mode:Jbuild.Rule.Mode.t
|
||||
-> ?context:Context.t
|
||||
-> ?locks:Path.t list
|
||||
-> ?loc:Loc.t
|
||||
|
@ -40,7 +42,7 @@ end
|
|||
(* must be called first *)
|
||||
val static_deps
|
||||
: (_, _) Build.t
|
||||
-> all_targets_by_dir:Path.Set.t Path.Map.t Lazy.t
|
||||
-> all_targets:(dir:Path.t -> Path.Set.t)
|
||||
-> Static_deps.t
|
||||
|
||||
val lib_deps
|
||||
|
|
1083
src/build_system.ml
1083
src/build_system.ml
File diff suppressed because it is too large
Load Diff
|
@ -4,15 +4,137 @@ open! Import
|
|||
|
||||
type t
|
||||
|
||||
(** {1 Creation} *)
|
||||
|
||||
(** Create a new build system. [file_tree] represent the source
|
||||
tree. *)
|
||||
val create
|
||||
: contexts:Context.t list
|
||||
-> file_tree:File_tree.t
|
||||
-> rules:Build_interpret.Rule.t list
|
||||
-> t
|
||||
|
||||
val is_target : t -> Path.t -> bool
|
||||
type extra_sub_directories_to_keep =
|
||||
| All
|
||||
| These of String_set.t
|
||||
|
||||
(** Set the rule generators callback. There must be one callback per
|
||||
build context name.
|
||||
|
||||
Each callback is used to generate the rules for a given directory
|
||||
in the corresponding build context. It receive the directory for
|
||||
which to generate the rules and the splitted part of the path after
|
||||
the build context. It must return an additional list of
|
||||
sub-directories to keep. This is in addition to the ones that are
|
||||
present in the source tree and the ones that already contain rules.
|
||||
|
||||
It is expected that [f] only generate rules whose targets are
|
||||
descendant of [dir]. *)
|
||||
val set_rule_generators : t -> (dir:Path.t -> string list -> extra_sub_directories_to_keep) String_map.t -> unit
|
||||
|
||||
(** {1 Primitive for rule generations} *)
|
||||
|
||||
(** Add a rule to the system. This function must be called from the [gen_rules]
|
||||
callback. All the target of the rule must be in the same directory.
|
||||
|
||||
Assuming that [gen_rules ~dir:a] calls [add_rule r] where [r.dir] is [Some b], one of
|
||||
the following assumption must hold:
|
||||
|
||||
- [a] and [b] are the same
|
||||
- [gen_rules ~dir:b] calls [load_dir ~dir:a]
|
||||
|
||||
The call to [load_dir ~dir:a] from [gen_rules ~dir:b] declares a directory dependency
|
||||
from [b] to [a]. There must be no cyclic directory dependencies.
|
||||
*)
|
||||
val add_rule : t -> Build_interpret.Rule.t -> unit
|
||||
|
||||
(** [eval_glob t ~dir re ~f] returns the list of files in [dir] that matches [re] to
|
||||
[f]. The list of files includes the list of targets. *)
|
||||
val eval_glob : t -> dir:Path.t -> Re.re -> string list
|
||||
|
||||
(** Returns the set of targets in the given directory. *)
|
||||
val targets_of : t -> dir:Path.t -> Path.Set.t
|
||||
|
||||
(** Load the rules for this directory. *)
|
||||
val load_dir : t -> dir:Path.t -> unit
|
||||
|
||||
(** [on_load_dir ~dir ~f] remembers to run [f] when loading the rules for [dir]. *)
|
||||
val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit
|
||||
|
||||
(** Stamp file that depends on all files of [dir] with extension [ext]. *)
|
||||
val stamp_file_for_files_of : t -> dir:Path.t -> ext:string -> Path.t
|
||||
|
||||
(** {1 Aliases} *)
|
||||
|
||||
module Alias : sig
|
||||
type build_system = t
|
||||
type t
|
||||
|
||||
val pp : t Fmt.t
|
||||
|
||||
val make : string -> dir:Path.t -> t
|
||||
|
||||
val of_path : Path.t -> t
|
||||
|
||||
(** The following always holds:
|
||||
|
||||
{[
|
||||
make (name t) ~dir:(dir t) = t
|
||||
]}
|
||||
*)
|
||||
val name : t -> string
|
||||
val dir : t -> Path.t
|
||||
|
||||
val fully_qualified_name : t -> Path.t
|
||||
|
||||
val default : dir:Path.t -> t
|
||||
val runtest : dir:Path.t -> t
|
||||
val install : dir:Path.t -> t
|
||||
val doc : dir:Path.t -> t
|
||||
val lint : dir:Path.t -> t
|
||||
|
||||
(** Return the underlying stamp file *)
|
||||
val stamp_file : t -> Path.t
|
||||
|
||||
(** [dep t = Build.path (stamp_file t)] *)
|
||||
val dep : t -> ('a, 'a) Build.t
|
||||
|
||||
(** Implements [(alias_rec ...)] in dependency specification *)
|
||||
val dep_rec
|
||||
: t
|
||||
-> loc:Loc.t
|
||||
-> file_tree:File_tree.t
|
||||
-> (unit, unit) Build.t
|
||||
|
||||
(** Implements [@alias] on the command line *)
|
||||
val dep_rec_multi_contexts
|
||||
: dir:Path.t
|
||||
-> name:string
|
||||
-> file_tree:File_tree.t
|
||||
-> contexts:string list
|
||||
-> (unit, unit) Build.t
|
||||
|
||||
(** [add_deps store alias deps] arrange things so that all [deps]
|
||||
are built as part of the build of alias [alias]. *)
|
||||
val add_deps : build_system -> t -> Path.t list -> unit
|
||||
|
||||
(** [add_action store alias ~stamp action] arrange things so that
|
||||
[action] is executed as part of the build of alias
|
||||
[alias]. [stamp] is any S-expression that is unique and
|
||||
persistent S-expression.
|
||||
*)
|
||||
val add_action
|
||||
: build_system
|
||||
-> t
|
||||
-> ?locks:Path.t list
|
||||
-> stamp:Sexp.t
|
||||
-> (unit, Action.t) Build.t
|
||||
-> unit
|
||||
end with type build_system := t
|
||||
|
||||
(** {1 Building} *)
|
||||
|
||||
module Build_error : sig
|
||||
(** Exception raised in case of build error *)
|
||||
type t
|
||||
|
||||
val backtrace : t -> Printexc.raw_backtrace
|
||||
|
@ -32,6 +154,10 @@ val do_build_exn
|
|||
-> request:(unit, unit) Build.t
|
||||
-> unit Future.t
|
||||
|
||||
(** {1 Other queries} *)
|
||||
|
||||
val is_target : t -> Path.t -> bool
|
||||
|
||||
(** Return all the library dependencies (as written by the user)
|
||||
needed to build this request *)
|
||||
val all_lib_deps
|
||||
|
@ -49,6 +175,14 @@ val all_lib_deps_by_context
|
|||
(** List of all buildable targets *)
|
||||
val all_targets : t -> Path.t list
|
||||
|
||||
(** Return the list of files that were created in the source tree and
|
||||
needs to be deleted *)
|
||||
val files_in_source_tree_to_delete
|
||||
: unit
|
||||
-> Path.t list
|
||||
|
||||
(** {1 Build rules} *)
|
||||
|
||||
(** A fully built rule *)
|
||||
module Rule : sig
|
||||
module Id : sig
|
||||
|
@ -75,8 +209,7 @@ val build_rules
|
|||
-> request:(unit, unit) Build.t
|
||||
-> Rule.t list Future.t
|
||||
|
||||
val all_targets_ever_built
|
||||
: unit
|
||||
-> Path.t list
|
||||
(** {1 Misc} *)
|
||||
|
||||
val dump_trace : t -> unit
|
||||
(** Dump various databases on disk *)
|
||||
val finalize : t -> unit
|
||||
|
|
|
@ -12,3 +12,4 @@ let capture_outputs = ref true
|
|||
let debug_backtraces = ref false
|
||||
let diff_command = ref None
|
||||
let auto_promote = ref false
|
||||
let force = ref false
|
||||
|
|
|
@ -41,3 +41,6 @@ val diff_command : string option ref
|
|||
|
||||
(** Automatically promote files *)
|
||||
val auto_promote : bool ref
|
||||
|
||||
(** Force re-running actions associated to aliases *)
|
||||
val force : bool ref
|
||||
|
|
|
@ -13,6 +13,19 @@ module Dir = struct
|
|||
let sub_dirs t = t.sub_dirs
|
||||
let ignored t = t.ignored
|
||||
|
||||
let file_paths t =
|
||||
Path.Set.of_string_set t.files ~f:(Path.relative t.path)
|
||||
|
||||
let sub_dir_names t =
|
||||
String_map.fold t.sub_dirs ~init:String_set.empty
|
||||
~f:(fun ~key:s ~data:_ acc ->
|
||||
String_set.add s acc)
|
||||
|
||||
let sub_dir_paths t =
|
||||
String_map.fold t.sub_dirs ~init:Path.Set.empty
|
||||
~f:(fun ~key:s ~data:_ acc ->
|
||||
Path.Set.add (Path.relative t.path s) acc)
|
||||
|
||||
let rec fold t ~traverse_ignored_dirs ~init:acc ~f =
|
||||
if not traverse_ignored_dirs && t.ignored then
|
||||
acc
|
||||
|
@ -89,6 +102,12 @@ let fold t ~traverse_ignored_dirs ~init ~f =
|
|||
let find_dir t path =
|
||||
Path.Map.find path t.dirs
|
||||
|
||||
let files_of t path =
|
||||
match find_dir t path with
|
||||
| None -> Path.Set.empty
|
||||
| Some dir ->
|
||||
Path.Set.of_string_set (Dir.files dir) ~f:(Path.relative path)
|
||||
|
||||
let file_exists t path fn =
|
||||
match Path.Map.find path t.dirs with
|
||||
| None -> false
|
||||
|
|
|
@ -5,7 +5,10 @@ module Dir : sig
|
|||
|
||||
val path : t -> Path.t
|
||||
val files : t -> String_set.t
|
||||
val file_paths : t -> Path.Set.t
|
||||
val sub_dirs : t -> t String_map.t
|
||||
val sub_dir_paths : t -> Path.Set.t
|
||||
val sub_dir_names : t -> String_set.t
|
||||
|
||||
(** Whether this directory is ignored by a [jbuild-ignore] file in
|
||||
one of its ancestor directories. *)
|
||||
|
@ -34,6 +37,8 @@ val root : t -> Dir.t
|
|||
|
||||
val find_dir : t -> Path.t -> Dir.t option
|
||||
|
||||
val files_of : t -> Path.t -> Path.Set.t
|
||||
|
||||
val exists : t -> Path.t -> bool
|
||||
val file_exists : t -> Path.t -> string -> bool
|
||||
|
||||
|
|
|
@ -387,30 +387,15 @@ module Scheduler = struct
|
|||
let rec split_paths targets_acc ctxs_acc = function
|
||||
| [] -> List.rev targets_acc, String_set.(elements (of_list ctxs_acc))
|
||||
| path :: rest ->
|
||||
match Path.extract_build_context path with
|
||||
| None ->
|
||||
let add_ctx ctx acc = if ctx = "default" then acc else ctx :: acc in
|
||||
match Utils.analyse_target path with
|
||||
| Other path ->
|
||||
split_paths (Path.to_string path :: targets_acc) ctxs_acc rest
|
||||
| Some ("default", filename) ->
|
||||
split_paths (Path.to_string filename :: targets_acc) ctxs_acc rest
|
||||
| Some (".aliases", filename) ->
|
||||
let ctxs_acc, filename =
|
||||
match Path.extract_build_context filename with
|
||||
| None -> ctxs_acc, Path.to_string filename
|
||||
| Some (ctx, fn) ->
|
||||
let strip_digest fn =
|
||||
let fn = Path.to_string fn in
|
||||
match String.rsplit2 fn ~on:'-' with
|
||||
| None -> assert false
|
||||
| Some (name, digest) ->
|
||||
assert (String.length digest = 32);
|
||||
name
|
||||
in
|
||||
let ctxs_acc =
|
||||
if ctx = "default" then ctxs_acc else ctx :: ctxs_acc in
|
||||
ctxs_acc, strip_digest fn in
|
||||
split_paths (("alias " ^ filename) :: targets_acc) ctxs_acc rest
|
||||
| Some (ctx, filename) ->
|
||||
split_paths (Path.to_string filename :: targets_acc) (ctx :: ctxs_acc) rest in
|
||||
| Regular (ctx, filename) ->
|
||||
split_paths (Path.to_string filename :: targets_acc) (add_ctx ctx ctxs_acc) rest
|
||||
| Alias (ctx, name) ->
|
||||
split_paths (("alias " ^ Path.to_string name) :: targets_acc) (add_ctx ctx ctxs_acc) rest
|
||||
in
|
||||
let target_names, contexts = split_paths [] [] targets in
|
||||
let target_names_grouped_by_prefix =
|
||||
List.map target_names ~f:Filename.split_extension_after_dot
|
||||
|
|
896
src/gen_rules.ml
896
src/gen_rules.ml
File diff suppressed because it is too large
Load Diff
|
@ -1,12 +1,11 @@
|
|||
open! Import
|
||||
open Jbuild
|
||||
|
||||
(* Generate rules. Returns evaluated jbuilds per context names. *)
|
||||
val gen
|
||||
: contexts:Context.t list
|
||||
-> build_system:Build_system.t
|
||||
-> ?filter_out_optional_stanzas_with_missing_deps:bool (* default: true *)
|
||||
-> ?only_packages:String_set.t
|
||||
-> ?unlink_aliases:string list
|
||||
-> Jbuild_load.conf
|
||||
-> (Build_interpret.Rule.t list *
|
||||
(* Evaluated jbuilds per context names *)
|
||||
(Path.t * Scope.t * Stanzas.t) list String_map.t) Future.t
|
||||
-> (Path.t * Scope.t * Stanzas.t) list String_map.t Future.t
|
||||
|
|
|
@ -2,7 +2,29 @@ include Jbuilder_re
|
|||
|
||||
module Array = StdLabels.Array
|
||||
module Bytes = StdLabels.Bytes
|
||||
module Set = MoreLabels.Set
|
||||
|
||||
module Set = struct
|
||||
module type OrderedType = MoreLabels.Set.OrderedType
|
||||
module type S = sig
|
||||
include MoreLabels.Set.S
|
||||
val map : f:(elt -> elt) -> t -> t
|
||||
end
|
||||
|
||||
module Make(Elt : OrderedType) : S with type elt = Elt.t = struct
|
||||
module M = MoreLabels.Set.Make(Elt)
|
||||
|
||||
include struct
|
||||
[@@@warning "-32"]
|
||||
(* [map] is only available since 4.04 *)
|
||||
let map ~f t =
|
||||
M.elements t
|
||||
|> List.map f
|
||||
|> M.of_list
|
||||
end
|
||||
|
||||
include M
|
||||
end
|
||||
end
|
||||
|
||||
external reraise : exn -> _ = "%reraise"
|
||||
|
||||
|
|
|
@ -66,3 +66,6 @@ let copy_file ~src ~dst =
|
|||
~finally:close_out
|
||||
~f:(fun oc ->
|
||||
copy_channels ic oc))
|
||||
|
||||
(* TODO: diml: improve this *)
|
||||
let compare_files fn1 fn2 = String.compare (read_file fn1) (read_file fn2)
|
||||
|
|
|
@ -16,6 +16,8 @@ val lines_of_file : string -> string list
|
|||
val read_file : string -> string
|
||||
val write_file : string -> string -> unit
|
||||
|
||||
val compare_files : string -> string -> int
|
||||
|
||||
val copy_channels : in_channel -> out_channel -> unit
|
||||
|
||||
val copy_file : src:string -> dst:string -> unit
|
||||
|
|
|
@ -727,18 +727,21 @@ module Rule = struct
|
|||
| Infer
|
||||
end
|
||||
|
||||
module Fallback = struct
|
||||
|
||||
module Mode = struct
|
||||
type t =
|
||||
| Yes
|
||||
| No
|
||||
| Not_possible
|
||||
| Standard
|
||||
| Fallback
|
||||
| Promote
|
||||
| Promote_but_delete_on_clean
|
||||
| Not_a_rule_stanza
|
||||
end
|
||||
|
||||
type t =
|
||||
{ targets : Targets.t
|
||||
; deps : Dep_conf.t list
|
||||
; action : Action.Unexpanded.t
|
||||
; fallback : Fallback.t
|
||||
; mode : Mode.t
|
||||
; locks : String_with_vars.t list
|
||||
; loc : Loc.t
|
||||
}
|
||||
|
@ -749,7 +752,7 @@ module Rule = struct
|
|||
{ targets = Infer
|
||||
; deps = []
|
||||
; action = Action.Unexpanded.t sexp
|
||||
; fallback = No
|
||||
; mode = Standard
|
||||
; locks = []
|
||||
; loc = Loc.none
|
||||
}
|
||||
|
@ -763,7 +766,7 @@ module Rule = struct
|
|||
return { targets = Static targets
|
||||
; deps
|
||||
; action
|
||||
; fallback = if fallback then Yes else No
|
||||
; mode = if fallback then Fallback else Standard
|
||||
; locks
|
||||
; loc = Loc.none
|
||||
})
|
||||
|
@ -785,7 +788,7 @@ module Rule = struct
|
|||
; S.virt_var __POS__ "@"
|
||||
; S.virt_var __POS__"<"
|
||||
]))
|
||||
; fallback = Not_possible
|
||||
; mode = Not_a_rule_stanza
|
||||
; locks = []
|
||||
; loc
|
||||
})
|
||||
|
@ -801,7 +804,7 @@ module Rule = struct
|
|||
(S.virt_var __POS__ "ROOT",
|
||||
Run (S.virt_text __POS__ "ocamlyacc",
|
||||
[S.virt_var __POS__ "<"]))
|
||||
; fallback = Not_possible
|
||||
; mode = Not_a_rule_stanza
|
||||
; locks = []
|
||||
; loc
|
||||
})
|
||||
|
@ -841,7 +844,7 @@ module Menhir = struct
|
|||
(S.virt_var __POS__ "ROOT",
|
||||
Run (S.virt_text __POS__ "menhir",
|
||||
t.flags @ [S.virt_var __POS__ "<"]))
|
||||
; fallback = Not_possible
|
||||
; mode = Not_a_rule_stanza
|
||||
; locks = []
|
||||
; loc
|
||||
})
|
||||
|
@ -861,7 +864,7 @@ module Menhir = struct
|
|||
; t.flags
|
||||
; [ S.virt_var __POS__ "^" ]
|
||||
]))
|
||||
; fallback = Not_possible
|
||||
; mode = Not_a_rule_stanza
|
||||
; locks = []
|
||||
; loc
|
||||
}]
|
||||
|
|
|
@ -203,20 +203,25 @@ module Rule : sig
|
|||
| Infer
|
||||
end
|
||||
|
||||
module Fallback : sig
|
||||
module Mode : sig
|
||||
type t =
|
||||
| Yes
|
||||
| No
|
||||
| Not_possible
|
||||
(** It is not possible to add a [(fallback)] field to the rule. For instance for
|
||||
[ocamllex], ... *)
|
||||
| Standard
|
||||
(** Only use this rule if the source files don't exist. *)
|
||||
| Fallback
|
||||
(** Silently promote the targets to the source tree. *)
|
||||
| Promote
|
||||
(** Same as [Promote] but [jbuilder clean] must delete the file *)
|
||||
| Promote_but_delete_on_clean
|
||||
(** Same as [Standard] however this is not a rule stanza, so it is not possible to
|
||||
add a [(fallback)] field to the rule. *)
|
||||
| Not_a_rule_stanza
|
||||
end
|
||||
|
||||
type t =
|
||||
{ targets : Targets.t
|
||||
; deps : Dep_conf.t list
|
||||
; action : Action.Unexpanded.t
|
||||
; fallback : Fallback.t
|
||||
; mode : Mode.t
|
||||
; locks : String_with_vars.t list
|
||||
; loc : Loc.t
|
||||
}
|
||||
|
|
|
@ -101,36 +101,34 @@ let build_cm sctx ~scope ~dir ~js_of_ocaml ~src =
|
|||
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target ]
|
||||
else []
|
||||
|
||||
let setup_separate_compilation_rules sctx =
|
||||
let setup_separate_compilation_rules sctx components =
|
||||
if separate_compilation_enabled ()
|
||||
then
|
||||
let ctx = SC.context sctx in
|
||||
let all_pkg =
|
||||
List.map
|
||||
(Findlib.all_packages ctx.findlib)
|
||||
~f:(fun pkg ->
|
||||
match components with
|
||||
| [] | _ :: _ :: _ -> ()
|
||||
| [pkg] ->
|
||||
let ctx = SC.context sctx in
|
||||
match Findlib.find ctx.findlib pkg ~required_by:[] with
|
||||
| None -> ()
|
||||
| Some pkg ->
|
||||
let pkg =
|
||||
(* Special case for the stdlib because it is not referenced in the META *)
|
||||
let pkg =
|
||||
if pkg.Findlib.name = "stdlib"
|
||||
then Findlib.stdlib_with_archives ctx.findlib
|
||||
else pkg
|
||||
in
|
||||
let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in
|
||||
pkg.Findlib.name, pkg.dir, archives)
|
||||
in
|
||||
List.concat_map all_pkg
|
||||
~f:(fun (pkg_name,pkg_dir,archives) ->
|
||||
List.map archives ~f:(fun fn ->
|
||||
match pkg.Findlib.name with
|
||||
| "stdlib" -> Findlib.stdlib_with_archives ctx.findlib
|
||||
| _ -> pkg
|
||||
in
|
||||
let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in
|
||||
List.iter archives ~f:(fun fn ->
|
||||
let name = Path.basename fn in
|
||||
let src = Path.relative pkg_dir name in
|
||||
let target = in_build_dir ~ctx [ pkg_name; sprintf "%s.js" name] in
|
||||
let dir = in_build_dir ~ctx [ pkg_name ] in
|
||||
let src = Path.relative pkg.dir name in
|
||||
let target = in_build_dir ~ctx [ pkg.name; sprintf "%s.js" name] in
|
||||
let dir = in_build_dir ~ctx [ pkg.name ] in
|
||||
let spec = Arg_spec.Dep src in
|
||||
Build.return (standard ())
|
||||
>>>
|
||||
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target
|
||||
))
|
||||
else []
|
||||
SC.add_rule sctx
|
||||
(Build.return (standard ())
|
||||
>>>
|
||||
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target)
|
||||
)
|
||||
|
||||
let build_exe sctx ~dir ~js_of_ocaml ~src =
|
||||
let {Jbuild.Js_of_ocaml.javascript_files; _} = js_of_ocaml in
|
||||
|
|
|
@ -19,6 +19,7 @@ val build_exe
|
|||
|
||||
val setup_separate_compilation_rules
|
||||
: Super_context.t
|
||||
-> (unit, Action.t) Build.t list
|
||||
-> string list
|
||||
-> unit
|
||||
|
||||
val standard : unit -> string list
|
||||
|
|
17
src/main.ml
17
src/main.ml
|
@ -15,7 +15,7 @@ let package_install_file { packages; _ } pkg =
|
|||
| Some p ->
|
||||
Ok (Path.relative p.path (Utils.install_file ~package:p.name ~findlib_toolchain:None))
|
||||
|
||||
let setup ?(log=Log.no_log) ?unlink_aliases
|
||||
let setup ?(log=Log.no_log)
|
||||
?filter_out_optional_stanzas_with_missing_deps
|
||||
?workspace ?(workspace_file="jbuild-workspace")
|
||||
?(use_findlib=true)
|
||||
|
@ -55,14 +55,15 @@ let setup ?(log=Log.no_log) ?unlink_aliases
|
|||
let contexts = List.concat contexts in
|
||||
List.iter contexts ~f:(fun (ctx : Context.t) ->
|
||||
Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp (Context.sexp_of_t ctx));
|
||||
let build_system =
|
||||
Build_system.create ~contexts ~file_tree:conf.file_tree
|
||||
in
|
||||
Gen_rules.gen conf
|
||||
~build_system
|
||||
~contexts
|
||||
?unlink_aliases
|
||||
?only_packages
|
||||
?filter_out_optional_stanzas_with_missing_deps
|
||||
>>= fun (rules, stanzas) ->
|
||||
let build_system = Build_system.create ~contexts
|
||||
~file_tree:conf.file_tree ~rules in
|
||||
>>= fun stanzas ->
|
||||
return { build_system
|
||||
; stanzas
|
||||
; contexts
|
||||
|
@ -211,7 +212,6 @@ let ignored_during_bootstrap =
|
|||
(* Called by the script generated by ../build.ml *)
|
||||
let bootstrap () =
|
||||
Ansi_color.setup_err_formatter_colors ();
|
||||
let pkg = "jbuilder" in
|
||||
let main () =
|
||||
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
|
||||
let subst () =
|
||||
|
@ -228,13 +228,14 @@ let bootstrap () =
|
|||
Clflags.debug_dep_path := true;
|
||||
let log = Log.create () in
|
||||
Future.Scheduler.go ~log
|
||||
(setup ~log ~workspace:{ merlin_context = Some "default"; contexts = [Default [Native]] }
|
||||
(setup ~log ~workspace:{ merlin_context = Some "default"
|
||||
; contexts = [Default [Native]] }
|
||||
~use_findlib:false
|
||||
~extra_ignored_subtrees:ignored_during_bootstrap
|
||||
()
|
||||
>>= fun { build_system = bs; _ } ->
|
||||
Build_system.do_build_exn bs
|
||||
~request:(Build.path (Path.(relative root) (pkg ^ ".install"))))
|
||||
~request:(Build.path (Path.of_string "_build/default/jbuilder.install")))
|
||||
in
|
||||
try
|
||||
main ()
|
||||
|
|
|
@ -17,7 +17,6 @@ val package_install_file : setup -> string -> (Path.t, unit) result
|
|||
it. *)
|
||||
val setup
|
||||
: ?log:Log.t
|
||||
-> ?unlink_aliases:string list
|
||||
-> ?filter_out_optional_stanzas_with_missing_deps:bool
|
||||
-> ?workspace:Workspace.t
|
||||
-> ?workspace_file:string
|
||||
|
|
|
@ -12,10 +12,10 @@ type t =
|
|||
; source_dirs: Path.Set.t
|
||||
}
|
||||
|
||||
let ppx_flags sctx ~dir ~src_dir:_ { preprocess; libname; _ } =
|
||||
let ppx_flags sctx ~dir:_ ~src_dir:_ { preprocess; libname; _ } =
|
||||
match preprocess with
|
||||
| Pps { pps; flags } ->
|
||||
let exe = SC.PP.get_ppx_driver sctx pps ~dir ~dep_kind:Optional in
|
||||
let exe = SC.PP.get_ppx_driver sctx pps in
|
||||
let command =
|
||||
List.map (Path.to_absolute_filename exe
|
||||
:: "--as-ppx"
|
||||
|
@ -28,14 +28,10 @@ let ppx_flags sctx ~dir ~src_dir:_ { preprocess; libname; _ } =
|
|||
| _ -> []
|
||||
|
||||
let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
|
||||
match Path.extract_build_context dir with
|
||||
| Some (_, remaindir) ->
|
||||
let path = Path.relative remaindir ".merlin" in
|
||||
SC.add_rule sctx
|
||||
(Build.path path
|
||||
>>>
|
||||
Build.write_file (Path.relative dir ".merlin-exists") "");
|
||||
SC.add_rule sctx (
|
||||
match Path.drop_build_context dir with
|
||||
| Some remaindir ->
|
||||
let merlin_file = Path.relative dir ".merlin" in
|
||||
SC.add_rule sctx ~mode:Promote_but_delete_on_clean (
|
||||
requires &&& flags
|
||||
>>^ (fun (libs, flags) ->
|
||||
let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in
|
||||
|
@ -82,7 +78,7 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
|
|||
|> List.map ~f:(Printf.sprintf "%s\n")
|
||||
|> String.concat ~sep:"")
|
||||
>>>
|
||||
Build.write_file_dyn path
|
||||
Build.write_file_dyn merlin_file
|
||||
)
|
||||
| _ ->
|
||||
()
|
||||
|
|
14
src/odoc.ml
14
src/odoc.ml
|
@ -155,7 +155,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~modules ~requires
|
|||
~f:(fun (m, _) -> m.Module.name = main_module_name)
|
||||
else
|
||||
modules_and_odoc_files
|
||||
in*)
|
||||
in*)
|
||||
let html_files =
|
||||
List.map modules_and_odoc_files ~f:(fun (m, odoc_file) ->
|
||||
to_html sctx m odoc_file ~doc_dir ~odoc ~dir ~includes ~lib
|
||||
|
@ -165,7 +165,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~modules ~requires
|
|||
lib_index sctx ~dir ~lib ~lib_unique_name ~lib_name ~doc_dir
|
||||
~modules ~includes ~odoc
|
||||
in
|
||||
Alias.add_deps (SC.aliases sctx) (Alias.doc ~dir)
|
||||
SC.add_alias_deps sctx (Build_system.Alias.doc ~dir)
|
||||
(css_file ~doc_dir
|
||||
:: toplevel_index ~doc_dir
|
||||
:: lib_index_html
|
||||
|
@ -227,3 +227,13 @@ let setup_toplevel_index_rule sctx =
|
|||
let context = SC.context sctx in
|
||||
let doc_dir = doc_dir ~context in
|
||||
SC.add_rule sctx @@ Build.write_file (toplevel_index ~doc_dir) html
|
||||
|
||||
let gen_rules sctx ~dir rest =
|
||||
match rest with
|
||||
| [] ->
|
||||
setup_css_rule sctx;
|
||||
setup_toplevel_index_rule sctx
|
||||
| lib :: _ ->
|
||||
match Lib_db.find (SC.libs sctx) ~from:dir lib with
|
||||
| None | Some (External _) -> ()
|
||||
| Some (Internal (dir, _)) -> SC.load_dir sctx ~dir
|
||||
|
|
|
@ -12,6 +12,4 @@ val setup_library_rules
|
|||
-> dep_graph:Ocamldep.dep_graph
|
||||
-> unit
|
||||
|
||||
val setup_css_rule : Super_context.t -> unit
|
||||
|
||||
val setup_toplevel_index_rule: Super_context.t -> unit
|
||||
val gen_rules : Super_context.t -> dir:Path.t -> string list -> unit
|
||||
|
|
44
src/path.ml
44
src/path.ml
|
@ -223,7 +223,9 @@ let compare = String.compare
|
|||
module Set = struct
|
||||
include String_set
|
||||
let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.elements t)
|
||||
let of_string_set = map
|
||||
end
|
||||
|
||||
module Map = String_map
|
||||
|
||||
module Kind = struct
|
||||
|
@ -346,9 +348,16 @@ let parent t =
|
|||
|
||||
let build_prefix = "_build/"
|
||||
|
||||
let build_dir = "_build"
|
||||
|
||||
let is_in_build_dir t =
|
||||
String.is_prefix t ~prefix:build_prefix
|
||||
|
||||
let is_in_source_tree t = is_local t && not (is_in_build_dir t)
|
||||
|
||||
let is_alias_stamp_file t =
|
||||
String.is_prefix t ~prefix:"_build/.aliases/"
|
||||
|
||||
let extract_build_context t =
|
||||
if String.is_prefix t ~prefix:build_prefix then
|
||||
let i = String.length build_prefix in
|
||||
|
@ -380,11 +389,39 @@ let extract_build_context_dir t =
|
|||
let drop_build_context t =
|
||||
Option.map (extract_build_context t) ~f:snd
|
||||
|
||||
let drop_build_context_exn t =
|
||||
match extract_build_context t with
|
||||
| None -> Sexp.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ]
|
||||
| Some (_, t) -> t
|
||||
|
||||
let drop_optional_build_context t =
|
||||
match extract_build_context t with
|
||||
| None -> t
|
||||
| Some (_, t) -> t
|
||||
|
||||
let split_first_component t =
|
||||
if is_local t && not (is_root t)then
|
||||
match String.index t '/' with
|
||||
| None -> Some (t, root)
|
||||
| Some i ->
|
||||
Some
|
||||
(String.sub t ~pos:0 ~len:i,
|
||||
String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1))
|
||||
else
|
||||
None
|
||||
|
||||
let explode t =
|
||||
if is_local t then
|
||||
Some (String.split t ~on:'/')
|
||||
else
|
||||
None
|
||||
|
||||
let explode_exn t =
|
||||
if is_local t then
|
||||
String.split t ~on:'/'
|
||||
else
|
||||
Sexp.code_error "Path.explode_exn" ["path", Atom t]
|
||||
|
||||
let exists t = Sys.file_exists (to_string t)
|
||||
let readdir t = Sys.readdir (to_string t) |> Array.to_list
|
||||
let is_directory t =
|
||||
|
@ -405,13 +442,10 @@ let insert_after_build_dir_exn =
|
|||
]
|
||||
in
|
||||
fun a b ->
|
||||
if not (is_local a && is_local b) then error a b;
|
||||
if not (is_local a) || String.contains 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
|
||||
sprintf "_build/%s/%s" b rest
|
||||
| _ ->
|
||||
error a b
|
||||
|
||||
|
|
21
src/path.mli
21
src/path.mli
|
@ -42,9 +42,12 @@ val compare : t -> t -> int
|
|||
module Set : sig
|
||||
include Set.S with type elt = t
|
||||
val sexp_of_t : t Sexp.To_sexp.t
|
||||
val of_string_set : f:(string -> elt) -> String_set.t -> t
|
||||
end
|
||||
|
||||
module Map : Map.S with type key = t
|
||||
|
||||
|
||||
val kind : t -> Kind.t
|
||||
|
||||
val of_string : ?error_loc:Loc.t -> string -> t
|
||||
|
@ -99,13 +102,29 @@ val extract_build_context_dir : t -> (t * t) option
|
|||
|
||||
(** Drop the "_build/blah" prefix *)
|
||||
val drop_build_context : t -> t option
|
||||
val drop_build_context_exn : t -> t
|
||||
|
||||
(** Drop the "_build/blah" prefix if present, return [t] otherwise *)
|
||||
val drop_optional_build_context : t -> t
|
||||
|
||||
val explode : t -> string list option
|
||||
val explode_exn : t -> string list
|
||||
|
||||
(** The build directory *)
|
||||
val build_dir : t
|
||||
|
||||
(** [is_in_build_dir t = is_descendant t ~of:build_dir] *)
|
||||
val is_in_build_dir : t -> bool
|
||||
|
||||
val insert_after_build_dir_exn : t -> t -> t
|
||||
(** [is_in_build_dir t = is_local t && not (is_in_build_dir t)] *)
|
||||
val is_in_source_tree : t -> bool
|
||||
|
||||
val is_alias_stamp_file : t -> bool
|
||||
|
||||
(** Split after the first component if [t] is local *)
|
||||
val split_first_component : t -> (string * t) option
|
||||
|
||||
val insert_after_build_dir_exn : t -> string -> t
|
||||
|
||||
val exists : t -> bool
|
||||
val readdir : t -> string list
|
||||
|
|
|
@ -3,6 +3,7 @@ open Jbuild
|
|||
|
||||
module A = Action
|
||||
module Pset = Path.Set
|
||||
module Alias = Build_system.Alias
|
||||
|
||||
module Dir_with_jbuild = struct
|
||||
type t =
|
||||
|
@ -13,72 +14,36 @@ module Dir_with_jbuild = struct
|
|||
}
|
||||
end
|
||||
|
||||
module External_dir = struct
|
||||
(* Files in the directory, grouped by extension *)
|
||||
type t = Path.t list String_map.t
|
||||
|
||||
let create ~dir : t =
|
||||
match Path.readdir dir with
|
||||
| exception _ -> String_map.empty
|
||||
| files ->
|
||||
List.map files ~f:(fun fn -> Filename.extension fn, Path.relative dir fn)
|
||||
|> String_map.of_alist_multi
|
||||
(* CR-someday jdimino: when we can have dynamic targets:
|
||||
|
||||
{[
|
||||
|> String_map.mapi ~f:(fun ext files ->
|
||||
lazy (
|
||||
let alias =
|
||||
Alias.make ~dir:Path.root (sprintf "external-files-%s%s" hash ext)
|
||||
in
|
||||
Alias.add_deps aliases alias files;
|
||||
alias
|
||||
))
|
||||
]}
|
||||
*)
|
||||
|
||||
let files t ~ext = String_map.find_default ext t ~default:[]
|
||||
end
|
||||
|
||||
type t =
|
||||
{ context : Context.t
|
||||
; libs : Lib_db.t
|
||||
; stanzas : Dir_with_jbuild.t list
|
||||
; packages : Package.t String_map.t
|
||||
; aliases : Alias.Store.t
|
||||
; file_tree : File_tree.t
|
||||
; artifacts : Artifacts.t
|
||||
; mutable rules : Build_interpret.Rule.t list
|
||||
; stanzas_to_consider_for_install : (Path.t * Stanza.t) list
|
||||
; mutable known_targets_by_src_dir_so_far : String_set.t Path.Map.t
|
||||
; libs_vfile : (module Vfile_kind.S with type t = Lib.t list)
|
||||
; cxx_flags : string list
|
||||
; vars : Action.Var_expansion.t String_map.t
|
||||
; ppx_dir : Path.t
|
||||
; ppx_drivers : (string, Path.t) Hashtbl.t
|
||||
; external_dirs : (Path.t, External_dir.t) Hashtbl.t
|
||||
; chdir : (Action.t, Action.t) Build.t
|
||||
; host : t option
|
||||
{ context : Context.t
|
||||
; build_system : Build_system.t
|
||||
; libs : Lib_db.t
|
||||
; stanzas : Dir_with_jbuild.t list
|
||||
; packages : Package.t String_map.t
|
||||
; file_tree : File_tree.t
|
||||
; artifacts : Artifacts.t
|
||||
; stanzas_to_consider_for_install : (Path.t * Stanza.t) list
|
||||
; libs_vfile : (module Vfile_kind.S with type t = Lib.t list)
|
||||
; cxx_flags : string list
|
||||
; vars : Action.Var_expansion.t String_map.t
|
||||
; ppx_dir : Path.t
|
||||
; chdir : (Action.t, Action.t) Build.t
|
||||
; host : t option
|
||||
}
|
||||
|
||||
let context t = t.context
|
||||
let aliases t = t.aliases
|
||||
let stanzas t = t.stanzas
|
||||
let packages t = t.packages
|
||||
let artifacts t = t.artifacts
|
||||
let file_tree t = t.file_tree
|
||||
let rules t = t.rules
|
||||
let stanzas_to_consider_for_install t = t.stanzas_to_consider_for_install
|
||||
let cxx_flags t = t.cxx_flags
|
||||
let libs t = t.libs
|
||||
|
||||
let host_sctx t = Option.value t.host ~default:t
|
||||
|
||||
let expand_var_no_root t var = String_map.find var t.vars
|
||||
|
||||
let get_external_dir t ~dir =
|
||||
Hashtbl.find_or_add t.external_dirs dir ~f:(fun dir ->
|
||||
External_dir.create ~dir)
|
||||
|
||||
let expand_vars t ~scope ~dir s =
|
||||
String_with_vars.expand s ~f:(fun _loc -> function
|
||||
| "ROOT" -> Some (Path.reach ~from:dir t.context.build_dir)
|
||||
|
@ -98,12 +63,12 @@ let resolve_program t ?hint bin =
|
|||
let create
|
||||
~(context:Context.t)
|
||||
?host
|
||||
~aliases
|
||||
~scopes
|
||||
~file_tree
|
||||
~packages
|
||||
~stanzas
|
||||
~filter_out_optional_stanzas_with_missing_deps
|
||||
~build_system
|
||||
=
|
||||
let stanzas =
|
||||
List.map stanzas
|
||||
|
@ -203,61 +168,55 @@ let create
|
|||
in
|
||||
{ context
|
||||
; host
|
||||
; build_system
|
||||
; libs
|
||||
; stanzas
|
||||
; packages
|
||||
; aliases
|
||||
; file_tree
|
||||
; rules = []
|
||||
; stanzas_to_consider_for_install
|
||||
; known_targets_by_src_dir_so_far = Path.Map.empty
|
||||
; libs_vfile = (module Libs_vfile)
|
||||
; artifacts
|
||||
; cxx_flags
|
||||
; vars
|
||||
; ppx_drivers = Hashtbl.create 32
|
||||
; ppx_dir = Path.relative context.build_dir ".ppx"
|
||||
; external_dirs = Hashtbl.create 1024
|
||||
; chdir = Build.arr (fun (action : Action.t) ->
|
||||
match action with
|
||||
| Chdir _ -> action
|
||||
| _ -> Chdir (context.build_dir, action))
|
||||
}
|
||||
|
||||
let add_rule t ?sandbox ?fallback ?locks ?loc build =
|
||||
let add_rule t ?sandbox ?mode ?locks ?loc build =
|
||||
let build = Build.O.(>>>) build t.chdir in
|
||||
Build_system.add_rule t.build_system
|
||||
(Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc
|
||||
~context:t.context build)
|
||||
|
||||
let add_rule_get_targets t ?sandbox ?mode ?locks ?loc build =
|
||||
let build = Build.O.(>>>) build t.chdir in
|
||||
let rule =
|
||||
Build_interpret.Rule.make ?sandbox ?fallback ?locks ?loc
|
||||
Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc
|
||||
~context:t.context build
|
||||
in
|
||||
t.rules <- rule :: t.rules;
|
||||
t.known_targets_by_src_dir_so_far <-
|
||||
List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far
|
||||
~f:(fun acc target ->
|
||||
match Path.extract_build_context (Build_interpret.Target.path target) with
|
||||
| None -> acc
|
||||
| Some (_, path) ->
|
||||
let dir = Path.parent path in
|
||||
let fn = Path.basename path in
|
||||
let files =
|
||||
match Path.Map.find dir acc with
|
||||
| None -> String_set.singleton fn
|
||||
| Some set -> String_set.add fn set
|
||||
in
|
||||
Path.Map.add acc ~key:dir ~data:files)
|
||||
Build_system.add_rule t.build_system rule;
|
||||
List.map rule.targets ~f:Build_interpret.Target.path
|
||||
|
||||
let add_rules t ?sandbox builds =
|
||||
List.iter builds ~f:(add_rule t ?sandbox)
|
||||
|
||||
let sources_and_targets_known_so_far t ~src_path =
|
||||
let sources =
|
||||
match File_tree.find_dir t.file_tree src_path with
|
||||
| None -> String_set.empty
|
||||
| Some dir -> File_tree.Dir.files dir
|
||||
in
|
||||
match Path.Map.find src_path t.known_targets_by_src_dir_so_far with
|
||||
| None -> sources
|
||||
| Some set -> String_set.union sources set
|
||||
let add_alias_deps t alias deps =
|
||||
Alias.add_deps t.build_system alias deps
|
||||
|
||||
let add_alias_action t alias ?locks ~stamp action =
|
||||
Alias.add_action t.build_system alias ?locks ~stamp action
|
||||
|
||||
let eval_glob t ~dir re = Build_system.eval_glob t.build_system ~dir re
|
||||
let load_dir t ~dir = Build_system.load_dir t.build_system ~dir
|
||||
let on_load_dir t ~dir ~f = Build_system.on_load_dir t.build_system ~dir ~f
|
||||
|
||||
let source_files t ~src_path =
|
||||
match File_tree.find_dir t.file_tree src_path with
|
||||
| None -> String_set.empty
|
||||
| Some dir -> File_tree.Dir.files dir
|
||||
|
||||
let unique_library_name t lib =
|
||||
Lib_db.unique_library_name t.libs lib
|
||||
|
@ -363,14 +322,7 @@ module Libs = struct
|
|||
in
|
||||
let requires =
|
||||
if t.context.merlin && has_dot_merlin then
|
||||
(* We don't depend on the dot_merlin directly, otherwise everytime it changes we
|
||||
would have to rebuild everything.
|
||||
|
||||
.merlin-exists depends on the .merlin and is an empty file. Depending on it
|
||||
forces the generation of the .merlin but not recompilation when it
|
||||
changes. Maybe one day we should add [Build.path_exists] to do the same in
|
||||
general. *)
|
||||
Build.path (Path.relative dir ".merlin-exists")
|
||||
Build.path (Path.relative dir ".merlin")
|
||||
>>>
|
||||
real_requires
|
||||
else
|
||||
|
@ -394,24 +346,21 @@ module Libs = struct
|
|||
Alias.make (sprintf "lib-%s%s-all" lib.name ext) ~dir
|
||||
|
||||
let setup_file_deps_alias t lib ~ext files =
|
||||
Alias.add_deps t.aliases (lib_files_alias lib ~ext) files
|
||||
add_alias_deps t (lib_files_alias lib ~ext) files
|
||||
|
||||
let setup_file_deps_group_alias t lib ~exts =
|
||||
setup_file_deps_alias t lib
|
||||
~ext:(String.concat exts ~sep:"-and-")
|
||||
(List.map exts ~f:(fun ext -> Alias.file (lib_files_alias lib ~ext)))
|
||||
(List.map exts ~f:(fun ext -> Alias.stamp_file (lib_files_alias lib ~ext)))
|
||||
|
||||
let file_deps t ~ext =
|
||||
Build.dyn_paths (Build.arr (fun libs ->
|
||||
List.fold_left libs ~init:[] ~f:(fun acc (lib : Lib.t) ->
|
||||
match lib with
|
||||
| External pkg -> begin
|
||||
List.rev_append
|
||||
(External_dir.files (get_external_dir t ~dir:pkg.dir) ~ext)
|
||||
acc
|
||||
end
|
||||
| External pkg ->
|
||||
Build_system.stamp_file_for_files_of t.build_system ~dir:pkg.dir ~ext :: acc
|
||||
| Internal lib ->
|
||||
Alias.file (lib_files_alias lib ~ext) :: acc)))
|
||||
Alias.stamp_file (lib_files_alias lib ~ext) :: acc)))
|
||||
|
||||
let static_file_deps ~ext lib =
|
||||
Alias.dep (lib_files_alias lib ~ext)
|
||||
|
@ -852,12 +801,31 @@ module PP = struct
|
|||
; Dyn (Lib.link_flags ~mode)
|
||||
])
|
||||
|
||||
let get_ppx_driver sctx pps ~dir ~dep_kind =
|
||||
let driver, names =
|
||||
let gen_rules sctx components =
|
||||
match components with
|
||||
| [key] ->
|
||||
let ppx_dir = Path.relative sctx.ppx_dir key in
|
||||
let exe = Path.relative ppx_dir "ppx.exe" in
|
||||
let names =
|
||||
match key with
|
||||
| "+none+" -> []
|
||||
| _ -> String.split key ~on:'+'
|
||||
in
|
||||
let driver, names =
|
||||
match List.rev names with
|
||||
| [] -> (None, [])
|
||||
| driver :: rest ->
|
||||
(Some driver, List.sort rest ~cmp:String.compare @ [driver])
|
||||
in
|
||||
build_ppx_driver sctx names ~dir:ppx_dir ~dep_kind:Required ~target:exe ~driver
|
||||
| _ -> ()
|
||||
|
||||
let get_ppx_driver sctx pps =
|
||||
let names =
|
||||
match List.rev_map pps ~f:Pp.to_string with
|
||||
| [] -> (None, [])
|
||||
| [] -> []
|
||||
| driver :: rest ->
|
||||
(Some driver, List.sort rest ~cmp:String.compare @ [driver])
|
||||
List.sort rest ~cmp:String.compare @ [driver]
|
||||
in
|
||||
let key =
|
||||
match names with
|
||||
|
@ -865,14 +833,8 @@ module PP = struct
|
|||
| _ -> String.concat names ~sep:"+"
|
||||
in
|
||||
let sctx = host_sctx sctx in
|
||||
match Hashtbl.find sctx.ppx_drivers key with
|
||||
| Some x -> x
|
||||
| None ->
|
||||
let ppx_dir = Path.relative sctx.ppx_dir key in
|
||||
let exe = Path.relative ppx_dir "ppx.exe" in
|
||||
build_ppx_driver sctx names ~dir ~dep_kind ~target:exe ~driver;
|
||||
Hashtbl.add sctx.ppx_drivers ~key ~data:exe;
|
||||
exe
|
||||
let ppx_dir = Path.relative sctx.ppx_dir key in
|
||||
Path.relative ppx_dir "ppx.exe"
|
||||
|
||||
let target_var = String_with_vars.virt_var __POS__ "@"
|
||||
let root_var = String_with_vars.virt_var __POS__ "ROOT"
|
||||
|
@ -933,12 +895,11 @@ module PP = struct
|
|||
~dep_kind ~lint ~lib_name ~scope =
|
||||
let alias = Alias.lint ~dir in
|
||||
let add_alias fn build =
|
||||
add_rule sctx
|
||||
(Alias.add_build (aliases sctx) alias build
|
||||
~stamp:(List [ Atom "lint"
|
||||
; Sexp.To_sexp.(option string) lib_name
|
||||
; Atom fn
|
||||
]))
|
||||
Alias.add_action sctx.build_system alias build
|
||||
~stamp:(List [ Atom "lint"
|
||||
; Sexp.To_sexp.(option string) lib_name
|
||||
; Atom fn
|
||||
])
|
||||
in
|
||||
match Preprocess_map.find source.name lint with
|
||||
| No_preprocessing -> ()
|
||||
|
@ -957,7 +918,7 @@ module PP = struct
|
|||
~scope)
|
||||
)
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
|
||||
let ppx_exe = get_ppx_driver sctx pps in
|
||||
Module.iter ast ~f:(fun kind src ->
|
||||
let src_path = Path.relative dir src.name in
|
||||
let args =
|
||||
|
@ -1020,7 +981,7 @@ module PP = struct
|
|||
lint_module ~ast ~source:m;
|
||||
ast
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
|
||||
let ppx_exe = get_ppx_driver sctx pps in
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
|
|
|
@ -23,41 +23,65 @@ type t
|
|||
val create
|
||||
: context:Context.t
|
||||
-> ?host:t
|
||||
-> aliases:Alias.Store.t
|
||||
-> scopes:Scope.t list
|
||||
-> file_tree:File_tree.t
|
||||
-> packages:Package.t String_map.t
|
||||
-> stanzas:(Path.t * Scope.t * Stanzas.t) list
|
||||
-> filter_out_optional_stanzas_with_missing_deps:bool
|
||||
-> build_system:Build_system.t
|
||||
-> t
|
||||
|
||||
val context : t -> Context.t
|
||||
val aliases : t -> Alias.Store.t
|
||||
val stanzas : t -> Dir_with_jbuild.t list
|
||||
val packages : t -> Package.t String_map.t
|
||||
val file_tree : t -> File_tree.t
|
||||
val artifacts : t -> Artifacts.t
|
||||
val stanzas_to_consider_for_install : t -> (Path.t * Stanza.t) list
|
||||
val cxx_flags : t -> string list
|
||||
val libs : t -> Lib_db.t
|
||||
|
||||
val expand_vars : t -> scope:Scope.t -> dir:Path.t -> String_with_vars.t -> string
|
||||
|
||||
val add_rule
|
||||
: t
|
||||
-> ?sandbox:bool
|
||||
-> ?fallback:Jbuild.Rule.Fallback.t
|
||||
-> ?mode:Jbuild.Rule.Mode.t
|
||||
-> ?locks:Path.t list
|
||||
-> ?loc:Loc.t
|
||||
-> (unit, Action.t) Build.t
|
||||
-> unit
|
||||
val add_rule_get_targets
|
||||
: t
|
||||
-> ?sandbox:bool
|
||||
-> ?mode:Jbuild.Rule.Mode.t
|
||||
-> ?locks:Path.t list
|
||||
-> ?loc:Loc.t
|
||||
-> (unit, Action.t) Build.t
|
||||
-> Path.t list
|
||||
val add_rules
|
||||
: t
|
||||
-> ?sandbox:bool
|
||||
-> (unit, Action.t) Build.t list
|
||||
-> unit
|
||||
val rules : t -> Build_interpret.Rule.t list
|
||||
val add_alias_deps
|
||||
: t
|
||||
-> Build_system.Alias.t
|
||||
-> Path.t list
|
||||
-> unit
|
||||
val add_alias_action
|
||||
: t
|
||||
-> Build_system.Alias.t
|
||||
-> ?locks:Path.t list
|
||||
-> stamp:Sexp.t
|
||||
-> (unit, Action.t) Build.t
|
||||
-> unit
|
||||
|
||||
val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t
|
||||
(** See [Build_system for details] *)
|
||||
val eval_glob : t -> dir:Path.t -> Re.re -> string list
|
||||
val load_dir : t -> dir:Path.t -> unit
|
||||
val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit
|
||||
|
||||
val source_files : t -> src_path:Path.t -> String_set.t
|
||||
|
||||
(** [prog_spec t ?hint name] resolve a program. [name] is looked up in the
|
||||
workspace, if it is not found in the tree is is looked up in the PATH. If it
|
||||
|
@ -174,16 +198,13 @@ module PP : sig
|
|||
-> Module.t String_map.t
|
||||
|
||||
(** Get a path to a cached ppx driver *)
|
||||
val get_ppx_driver
|
||||
: t
|
||||
-> Pp.t list
|
||||
-> dir:Path.t
|
||||
-> dep_kind:Build.lib_dep_kind
|
||||
-> Path.t
|
||||
val get_ppx_driver : t -> Pp.t list -> Path.t
|
||||
|
||||
(** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not
|
||||
[None] *)
|
||||
val cookie_library_name : string option -> string list
|
||||
|
||||
val gen_rules : t -> string list -> unit
|
||||
end
|
||||
|
||||
val expand_and_eval_set
|
||||
|
|
49
src/utils.ml
49
src/utils.ml
|
@ -73,19 +73,44 @@ let jbuild_name_in ~dir =
|
|||
(Path.to_string_maybe_quoted (Path.relative dir "jbuild"))
|
||||
ctx_name
|
||||
|
||||
let describe_target fn =
|
||||
type target_kind =
|
||||
| Regular of string * Path.t
|
||||
| Alias of string * Path.t
|
||||
| Other of Path.t
|
||||
|
||||
let analyse_target fn =
|
||||
match Path.extract_build_context fn with
|
||||
| Some (".aliases", fn) ->
|
||||
let name =
|
||||
let fn = Path.to_string fn in
|
||||
match String.rsplit2 fn ~on:'-' with
|
||||
| None -> assert false
|
||||
| Some (name, digest) ->
|
||||
assert (String.length digest = 32);
|
||||
name
|
||||
in
|
||||
sprintf "alias %s" (maybe_quoted name)
|
||||
| _ ->
|
||||
| Some (".aliases", sub) -> begin
|
||||
match Path.split_first_component sub with
|
||||
| None -> Other fn
|
||||
| Some (ctx, fn) ->
|
||||
if Path.is_root fn then
|
||||
Other fn
|
||||
else
|
||||
let basename =
|
||||
match String.rsplit2 (Path.basename fn) ~on:'-' with
|
||||
| None -> assert false
|
||||
| Some (name, digest) ->
|
||||
assert (String.length digest = 32);
|
||||
name
|
||||
in
|
||||
Alias (ctx, Path.relative (Path.parent fn) basename)
|
||||
end
|
||||
| Some (ctx, sub) -> Regular (ctx, sub)
|
||||
| None ->
|
||||
Other fn
|
||||
|
||||
let describe_target fn =
|
||||
let ctx_suffix = function
|
||||
| "default" -> ""
|
||||
| ctx -> sprintf " (context %s)" ctx
|
||||
in
|
||||
match analyse_target fn with
|
||||
| Alias (ctx, p) ->
|
||||
sprintf "alias %s%s" (Path.to_string_maybe_quoted p) (ctx_suffix ctx)
|
||||
| Regular (ctx, fn) ->
|
||||
sprintf "%s%s" (Path.to_string_maybe_quoted fn) (ctx_suffix ctx)
|
||||
| Other fn ->
|
||||
Path.to_string_maybe_quoted fn
|
||||
|
||||
let program_not_found ?context ?hint prog =
|
||||
|
|
|
@ -18,6 +18,14 @@ val jbuild_name_in : dir:Path.t -> string
|
|||
(** Nice description of a target *)
|
||||
val describe_target : Path.t -> string
|
||||
|
||||
type target_kind =
|
||||
| Regular of string (* build context *) * Path.t
|
||||
| Alias of string (* build context *) * Path.t
|
||||
| Other of Path.t
|
||||
|
||||
(** Return the name of an alias from its stamp file *)
|
||||
val analyse_target : Path.t -> target_kind
|
||||
|
||||
(** Raise an error about a program not found in the PATH or in the tree *)
|
||||
val program_not_found
|
||||
: ?context:string
|
||||
|
|
|
@ -12,11 +12,11 @@
|
|||
running in src/foo/baz
|
||||
running in src
|
||||
$ $JBUILDER build -j1 --root . @plop
|
||||
File "<command-line>", line 1, characters 0-0:
|
||||
Error: This alias is empty.
|
||||
Alias "plop" is not defined in . or any of its descendants.
|
||||
From the command line:
|
||||
Error: Alias plop is empty.
|
||||
It is not defined in . or any of its descendants.
|
||||
[1]
|
||||
$ $JBUILDER build -j1 --root . @truc/x
|
||||
File "<command-line>", line 1, characters 0-0:
|
||||
From the command line:
|
||||
Error: Don't know about directory truc!
|
||||
[1]
|
||||
|
|
|
@ -23,5 +23,4 @@
|
|||
|
||||
(alias
|
||||
((name runtest)
|
||||
(deps (META.foobar))
|
||||
(action (echo "${read:META.foobar}"))))
|
||||
(action (echo "${read:META.foobar}"))))
|
||||
|
|
Loading…
Reference in New Issue