From 9dd5ab74e48d99101691d2ab4292439b9e2ff98b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Fri, 19 Jan 2018 08:50:06 +0000 Subject: [PATCH] [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. --- CHANGES.md | 9 + bin/main.ml | 105 +- doc/advanced-topics.rst | 27 +- doc/usage.rst | 30 +- src/action.ml | 2 +- src/alias.ml | 210 ---- src/alias.mli | 95 -- src/build_interpret.ml | 67 +- src/build_interpret.mli | 8 +- src/build_system.ml | 1083 ++++++++++++----- src/build_system.mli | 145 ++- src/clflags.ml | 1 + src/clflags.mli | 3 + src/file_tree.ml | 19 + src/file_tree.mli | 5 + src/future.ml | 31 +- src/gen_rules.ml | 896 +++++++------- src/gen_rules.mli | 7 +- src/import.ml | 24 +- src/io.ml | 3 + src/io.mli | 2 + src/jbuild.ml | 25 +- src/jbuild.mli | 19 +- src/js_of_ocaml_rules.ml | 48 +- src/js_of_ocaml_rules.mli | 3 +- src/main.ml | 17 +- src/main.mli | 1 - src/merlin.ml | 18 +- src/odoc.ml | 14 +- src/odoc.mli | 4 +- src/path.ml | 44 +- src/path.mli | 21 +- src/super_context.ml | 199 ++- src/super_context.mli | 43 +- src/utils.ml | 49 +- src/utils.mli | 8 + test/blackbox-tests/test-cases/aliases/run.t | 8 +- .../blackbox-tests/test-cases/meta-gen/jbuild | 3 +- 38 files changed, 1891 insertions(+), 1405 deletions(-) delete mode 100644 src/alias.ml delete mode 100644 src/alias.mli diff --git a/CHANGES.md b/CHANGES.md index 6ddc2591..4a3802ba 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -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) ----------------------- diff --git a/bin/main.ml b/bin/main.ml index 52c568f0..a0d5efb5 100644 --- a/bin/main.ml +++ b/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 "") - ~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 diff --git a/doc/advanced-topics.rst b/doc/advanced-topics.rst index 74f1d2f6..14a4e8ff 100644 --- a/doc/advanced-topics.rst +++ b/doc/advanced-topics.rst @@ -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.`` file in the same directory as the ``.opam`` -file. If you do that, Jbuilder will still generate a ``META`` file but -it will be called ``META..from-jbuilder``. So for instance if -you want to extend the ``META`` file generated by Jbuilder you can -write: +``META..template`` file in the same directory as the +``.opam`` file. Jbuilder will generate a ``META.`` +file from the ``META..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..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: diff --git a/doc/usage.rst b/doc/usage.rst index 1dd7f74e..20059b74 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -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 -- ``.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 +- ``.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: diff --git a/src/action.ml b/src/action.ml index 457b7b8e..81c349b7 100644 --- a/src/action.ml +++ b/src/action.ml @@ -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 = diff --git a/src/alias.ml b/src/alias.ml deleted file mode 100644 index 7f845722..00000000 --- a/src/alias.ml +++ /dev/null @@ -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 diff --git a/src/alias.mli b/src/alias.mli deleted file mode 100644 index 35a006df..00000000 --- a/src/alias.mli +++ /dev/null @@ -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 - diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 0a140de5..5e02002b 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -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 diff --git a/src/build_interpret.mli b/src/build_interpret.mli index 39ac5c20..4b30d0e8 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -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 diff --git a/src/build_system.ml b/src/build_system.ml index aceb020e..a92f667a 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -5,6 +5,38 @@ module Pset = Path.Set module Pmap = Path.Map module Vspec = Build.Vspec +(* Where we store stamp files for aliases *) +let alias_dir = Path.(relative build_dir) ".aliases" + +(* Where we store stamp files for [stamp_file_for_files_of] *) +let misc_dir = Path.(relative build_dir) ".misc" + +module Promoted_to_delete = struct + let db = ref [] + + let fn = "_build/.to-delete-in-source-tree" + + let add p = db := p :: !db + + let load () = + if Sys.file_exists fn then + Sexp.load ~fname:fn ~mode:Many + |> List.map ~f:Path.t + else + [] + + let dump () = + let db = Pset.union (Pset.of_list !db) (Pset.of_list (load ())) in + if Sys.file_exists "_build" then + Io.write_file fn + (String.concat ~sep:"" + (List.map (Pset.elements db) ~f:(fun p -> + Sexp.to_string (Path.sexp_of_t p) ^ "\n"))) +end + +let files_in_source_tree_to_delete () = + Promoted_to_delete.load () + module Exec_status = struct module Starting = struct type t = { for_file : Path.t } @@ -40,6 +72,14 @@ module Exec_status = struct | Running of Running.t end +let rule_loc ~loc ~dir = + match loc with + | Some loc -> loc + | None -> + Loc.in_file + (Path.to_string + (Path.drop_optional_build_context (Path.relative dir "jbuild"))) + module Internal_rule = struct module Id : sig type t @@ -58,15 +98,6 @@ module Internal_rule = struct n end - module Fallback_status = struct - type t = - (* The argument is the set of targets that are already present in the source - tree. *) - | Yes of Pset.t - | No - | Not_possible - end - type t = { id : Id.t ; rule_deps : Pset.t @@ -74,20 +105,14 @@ module Internal_rule = struct ; targets : Pset.t ; context : Context.t option ; build : (unit, Action.t) Build.t - ; mutable fallback : Fallback_status.t + ; mode : Jbuild.Rule.Mode.t ; loc : Loc.t option ; mutable exec : Exec_status.t } let compare a b = Id.compare a.id b.id - let loc ~dir t = - match t.loc with - | Some loc -> loc - | None -> - Loc.in_file - (Path.to_string - (Path.drop_optional_build_context (Path.relative dir "jbuild"))) + let loc ~dir t = rule_loc ~dir ~loc:t.loc end module File_kind = struct @@ -117,26 +142,195 @@ module File_spec = struct T { rule; kind; data = None } end +module Alias0 = struct + type t = { dir : Path.t; name : string } + + let pp fmt t = Path.pp fmt (Path.relative t.dir t.name) + + let suffix = "-" ^ String.make 32 '0' + + let of_path path = + if not (Path.is_in_build_dir path) then + die "Invalid alias!\nTried to reference alias %S" + (Path.to_string_maybe_quoted path); + { dir = Path.parent path + ; name = Path.basename path + } + + let name t = t.name + let dir t = t.dir + + let fully_qualified_name t = Path.relative t.dir t.name + + let make name ~dir = + assert (not (String.contains name '/')); + { dir; name } + + let stamp_file t = + Path.relative (Path.insert_after_build_dir_exn t.dir ".aliases") (t.name ^ suffix) + + let dep t = Build.path (stamp_file t) + + let is_standard = function + | "runtest" | "install" | "doc" | "lint" -> true + | _ -> false + + open Build.O + + let dep_rec_internal ~name ~dir ~ctx_dir = + File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true) + ~f:(fun dir acc -> + let path = Path.append ctx_dir (File_tree.Dir.path dir) in + let fn = stamp_file (make ~dir:path name) in + acc + >>> + Build.if_file_exists fn + ~then_:(Build.path fn >>^ fun _ -> false) + ~else_:(Build.arr (fun x -> x))) + + let dep_rec t ~loc ~file_tree = + let ctx_dir, src_dir = Path.extract_build_context_dir t.dir |> Option.value_exn in + match File_tree.find_dir file_tree src_dir with + | None -> Build.fail { fail = fun () -> + Loc.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) } + | Some dir -> + dep_rec_internal ~name:t.name ~dir ~ctx_dir + >>^ fun is_empty -> + if is_empty && not (is_standard t.name) then + Loc.fail loc "This alias is empty.\n\ + Alias %S is not defined in %s or any of its descendants." + t.name (Path.to_string_maybe_quoted src_dir) + + let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts = + match File_tree.find_dir file_tree src_dir with + | None -> + die "From the command line:\n\ + @{Error@}: Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) + | Some dir -> + let open Build.O in + Build.all (List.map contexts ~f:(fun ctx -> + let ctx_dir = Path.(relative build_dir) ctx in + dep_rec_internal ~name ~dir ~ctx_dir)) + >>^ fun is_empty_list -> + let is_empty = List.for_all is_empty_list ~f:(fun x -> x) in + if is_empty && not (is_standard name) then + die "From the command line:\n\ + @{Error@}: Alias %s is empty.\n\ + It is not defined in %s or any of its descendants." + name (Path.to_string_maybe_quoted src_dir) + + let default = make "DEFAULT" + let runtest = make "runtest" + let install = make "install" + let doc = make "doc" + let lint = make "lint" +end + +module Dir_status = struct + type waiting_for_load_dir = + { mutable lazy_generators : (unit -> unit) list } + + type collection_stage = + | Loading + | Pending of waiting_for_load_dir + + type alias_action = + { stamp : Digest.t + ; action : (unit, Action.t) Build.t + ; locks : Path.t list + } + + + type alias = + { mutable deps : Pset.t + ; mutable actions : alias_action list + } + + type rules_collector = + { mutable rules : Build_interpret.Rule.t list + ; mutable aliases : alias String_map.t + ; mutable stage : collection_stage + } + + type t = + | Collecting_rules of rules_collector + | Loaded of Pset.t (* set of targets in the directory *) + | Forward of Path.t (* Load this directory first *) +end + +module Files_of = struct + type t = + { files_by_ext : Path.t list String_map.t + ; dir_hash : string + ; mutable stamps : Path.t String_map.t + } +end + +type extra_sub_directories_to_keep = + | All + | These of String_set.t + 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 String_map.t ; (* Table from target to digest of [(deps (filename + contents), targets (filename only), action)] *) - trace : (Path.t, Digest.t) Hashtbl.t + trace : (Path.t, Digest.t) Hashtbl.t + ; file_tree : File_tree.t ; mutable local_mkdirs : Path.Local.Set.t - ; all_targets_by_dir : Pset.t Pmap.t Lazy.t + ; mutable dirs : (Path.t, Dir_status.t) Hashtbl.t + ; mutable gen_rules : (dir:Path.t -> string list -> extra_sub_directories_to_keep) String_map.t + ; mutable load_dir_stack : Path.t list + ; (* Set of directories under _build that have at least one rule and + all their ancestors. *) + mutable build_dirs_to_keep : Path.Set.t + ; files_of : (Path.t, Files_of.t) Hashtbl.t } -let all_targets t = Hashtbl.fold t.files ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) +let string_of_paths set = + Pset.elements set + |> List.map ~f:(fun p -> sprintf "- %s" + (Path.to_string_maybe_quoted + (Path.drop_optional_build_context p))) + |> String.concat ~sep:"\n" + +let set_rule_generators t generators = + assert (String_map.keys generators = String_map.keys t.contexts); + t.gen_rules <- generators + +let get_dir_status t ~dir = + Hashtbl.find_or_add t.dirs dir ~f:(fun _ -> + if Path.is_in_source_tree dir then + Dir_status.Loaded (File_tree.files_of t.file_tree dir) + else if dir = Path.build_dir then + (* Not allowed to look here *) + Dir_status.Loaded Pset.empty + else if not (Path.is_local dir) then + Dir_status.Loaded + (match Path.readdir dir with + | exception _ -> Path.Set.empty + | files -> + Pset.of_list (List.map files ~f:(Path.relative dir))) + else begin + let (ctx, sub_dir) = Option.value_exn (Path.extract_build_context dir) in + if ctx = ".aliases" then + Forward (Path.(append build_dir) sub_dir) + else if ctx <> "install" && not (String_map.mem ctx t.contexts) then + Dir_status.Loaded Pset.empty + else + Collecting_rules + { rules = [] + ; aliases = String_map.empty + ; stage = Pending { lazy_generators = [] } + } + end) 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 _ -> "") -let is_target t file = Hashtbl.mem t.files file - module Build_error = struct type t = { backtrace : Printexc.raw_backtrace @@ -175,62 +369,8 @@ let wrap_build_errors t ~f ~targeting = | Build_error.E _ -> reraise exn | exn -> Build_error.raise t exn ~targeting ~backtrace) -let wait_for_file t fn ~targeting = - match Hashtbl.find t.files fn with - | None -> - if Path.is_in_build_dir fn then - die "no rule found for %s" (Utils.describe_target fn) - else if Path.exists fn then - return () - else - die "file unavailable: %s" (Path.to_string fn) - | Some (File_spec.T file) -> - match file.rule.exec with - | Not_started { eval_rule; exec_rule } -> - file.rule.exec <- Starting { for_file = targeting }; - let rule_evaluation = - wrap_build_errors t ~targeting:fn ~f:eval_rule - in - let rule_execution = - wrap_build_errors t ~targeting:fn ~f:(exec_rule rule_evaluation) - in - file.rule.exec <- - Running { for_file = targeting - ; rule_evaluation - ; rule_execution - }; - rule_execution - | Running { rule_execution; _ } -> rule_execution - | Evaluating_rule { for_file; rule_evaluation; exec_rule } -> - file.rule.exec <- Starting { for_file = targeting }; - let rule_execution = - wrap_build_errors t ~targeting:fn ~f:(exec_rule rule_evaluation) - in - file.rule.exec <- - Running { for_file - ; rule_evaluation - ; rule_execution - }; - rule_execution - | Starting _ -> - (* Recursive deps! *) - let rec build_loop acc targeting = - let acc = targeting :: acc in - if fn = targeting then - acc - else - let (File_spec.T file) = find_file_exn t targeting in - match file.rule.exec with - | Not_started _ | Running _ | Evaluating_rule _ -> assert false - | Starting { for_file } -> - build_loop acc for_file - in - let loop = build_loop [fn] targeting in - die "Dependency cycle between the following files:\n %s" - (String.concat ~sep:"\n--> " - (List.map loop ~f:Path.to_string)) - module Target = Build_interpret.Target +module Pre_rule = Build_interpret.Rule let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn kind -> match Hashtbl.find t.files fn with @@ -310,24 +450,14 @@ module Build_exec = struct snd (exec bs (Build.O.(>>^) t (fun () -> Action.Progn [])) x) end -(* This variable is filled during the creation of the build system. Once the build system - is created, we check that all the fallback rules that got disabled are completely - disabled, i.e. that all their targets already exist in the source tree. *) -let disabled_fallback_rules = ref [] - (* [copy_source] is [true] for rules copying files from the source directory *) let add_spec t fn spec ~copy_source = match Hashtbl.find t.files fn with | None -> Hashtbl.add t.files ~key:fn ~data:spec | Some (File_spec.T { rule; _ }) -> - match copy_source, rule.fallback with - | true, Yes already_present -> - if Pset.is_empty already_present then - disabled_fallback_rules := rule :: !disabled_fallback_rules; - rule.fallback <- Yes (Pset.add fn already_present); - Hashtbl.add t.files ~key:fn ~data:spec - | true, (No | Not_possible) -> + match copy_source, rule.mode with + | true, (Standard | Not_a_rule_stanza) -> Loc.warn (Internal_rule.loc rule ~dir:(Path.parent fn)) "File %s is both generated by a rule and present in the source tree.\n\ As a result, the rule is currently ignored, however this will become an error \ @@ -335,18 +465,32 @@ let add_spec t fn spec ~copy_source = %t" (maybe_quoted (Path.basename fn)) (fun ppf -> - match rule.fallback with - | Yes _ -> assert false - | Not_possible -> + match rule.mode with + | Not_a_rule_stanza -> Format.fprintf ppf "Delete file %s to get rid of this warning." (Path.to_string_maybe_quoted (Path.drop_optional_build_context fn)) - | No -> + | Standard -> Format.fprintf ppf "To keep the current behavior and get rid of this warning, add a field \ - (fallback) to the rule."); + (fallback) to the rule." + | _ -> assert false); Hashtbl.add t.files ~key:fn ~data:spec - | false, _ -> - die "multiple rules generated for %s" (Path.to_string_maybe_quoted fn) + | _ -> + let (File_spec.T { rule = rule2; _ }) = spec in + let string_of_loc = function + | None -> "" + | Some { Loc.start; _ } -> + start.pos_fname ^ ":" ^ string_of_int start.pos_lnum + in + die "Multiple rules generated for %s:\n\ + - %s\n\ + - %s" + (Path.to_string_maybe_quoted fn) + (if copy_source then + "" + else + string_of_loc rule.loc) + (string_of_loc rule2.loc) let create_file_specs t targets rule ~copy_source = List.iter targets ~f:(function @@ -355,7 +499,15 @@ let create_file_specs t targets rule ~copy_source = | Target.Vfile (Vspec.T (fn, kind)) -> add_spec t fn (File_spec.create rule (Sexp_file kind)) ~copy_source) -module Pre_rule = Build_interpret.Rule +(* This contains the targets of the actions that are being executed. On exit, we need to + delete them as they might contain garbage *) +let pending_targets = ref Pset.empty + +let () = + Future.Scheduler.at_exit_after_waiting_for_commands (fun () -> + let fns = !pending_targets in + pending_targets := Pset.empty; + Pset.iter fns ~f:Path.unlink_no_err) let clear_targets_digests_after_rule_execution targets = let missing = @@ -368,23 +520,7 @@ let clear_targets_digests_after_rule_execution targets = in if not (Pset.is_empty missing) then die "@{Error@}: Rule failed to generate the following targets:\n%s" - (Pset.elements missing - |> List.map ~f:(fun fn -> sprintf "- %s" (Path.to_string fn)) - |> String.concat ~sep:"\n") - -let wait_for_deps t deps ~targeting = - all_unit - (Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc)) - -(* This contains the targets of the actions that are being executed. On exit, we need to - delete them as they might contain garbage *) -let pending_targets = ref Pset.empty - -let () = - Future.Scheduler.at_exit_after_waiting_for_commands (fun () -> - let fns = !pending_targets in - pending_targets := Pset.empty; - Pset.iter fns ~f:Path.unlink_no_err) + (string_of_paths missing) let make_local_dirs t paths = Pset.iter paths ~f:(fun path -> @@ -419,15 +555,58 @@ let rec with_locks mutexes ~f = (Hashtbl.find_or_add locks m ~f:(fun _ -> Future.Mutex.create ())) (fun () -> with_locks mutexes ~f) -let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = +let remove_old_artifacts t ~dir ~subdirs_to_keep = + if not (Path.is_in_build_dir dir) || + Hashtbl.mem t.files (Path.relative dir Config.jbuilder_keep_fname) then + () + else + match Path.readdir dir with + | exception _ -> () + | files -> + List.iter files ~f:(fun fn -> + let path = Path.relative dir fn in + match Unix.lstat (Path.to_string path) with + | { st_kind = S_DIR; _ } -> begin + match subdirs_to_keep with + | All -> () + | These set -> + if String_set.mem fn set || + Pset.mem path t.build_dirs_to_keep then + () + else + Path.rm_rf path + end + | exception _ -> + if not (Hashtbl.mem t.files path) then Path.unlink path + | _ -> + if not (Hashtbl.mem t.files path) then Path.unlink path) + +let no_rule_found = + let fail fn = + die "No rule found for %s" (Utils.describe_target fn) + in + fun t fn -> + match Path.extract_build_context fn with + | None -> fail fn + | Some (ctx, _) -> + if String_map.mem ctx t.contexts then + fail fn + else + die "Trying to build %s but build context %s doesn't exist.%s" + (Path.to_string_maybe_quoted fn) + ctx + (hint ctx (String_map.keys t.contexts)) + +let rec compile_rule t ?(copy_source=false) pre_rule = let { Pre_rule. context ; build ; targets = target_specs ; sandbox - ; fallback + ; mode ; locks ; loc + ; dir = _ } = pre_rule in @@ -435,7 +614,7 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = let { Build_interpret.Static_deps. rule_deps ; action_deps = static_deps - } = Build_interpret.static_deps build ~all_targets_by_dir + } = Build_interpret.static_deps build ~all_targets:(load_dir t) in let eval_rule ~targeting = @@ -487,7 +666,11 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = | exception _ -> true | (_ : Unix.stats) -> false) in - if deps_or_rule_changed || targets_missing then ( + let force = + !Clflags.force && + List.exists targets_as_list ~f:Path.is_alias_stamp_file + in + if deps_or_rule_changed || targets_missing || force then ( (* Do not remove files that are just updated, otherwise this would break incremental compilation *) let targets_to_remove = @@ -520,7 +703,17 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = Option.iter sandbox_dir ~f:Path.rm_rf; (* All went well, these targets are no longer pending *) pending_targets := Pset.diff !pending_targets targets_to_remove; - clear_targets_digests_after_rule_execution targets_as_list + clear_targets_digests_after_rule_execution targets_as_list; + match mode with + | Standard | Fallback | Not_a_rule_stanza -> () + | Promote | Promote_but_delete_on_clean -> + Pset.iter targets ~f:(fun path -> + let in_source_tree = Option.value_exn (Path.drop_build_context path) in + if mode = Promote_but_delete_on_clean then + Promoted_to_delete.add in_source_tree; + Io.copy_file + ~src:(Path.to_string path) + ~dst:(Path.to_string in_source_tree)) ) else return () in @@ -533,35 +726,327 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = ; build ; context ; exec = Not_started { eval_rule; exec_rule } - ; fallback = (match fallback with - | Yes -> Yes Pset.empty - | No -> No - | Not_possible -> Not_possible) + ; mode ; loc } in create_file_specs t target_specs rule ~copy_source -let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir = - List.iter t.contexts ~f:(fun (ctx : Context.t) -> - let ctx_dir = ctx.build_dir in - Pset.iter all_non_target_source_files ~f:(fun path -> - let ctx_path = Path.append ctx_dir path in - if is_target t ctx_path && - String.is_suffix (Path.basename ctx_path) ~suffix:".install" then - (* Do not copy over .install files that are generated by a rule. *) - () - else - let build = Build.copy ~src:path ~dst:ctx_path in - (* We temporarily allow overrides while setting up copy rules - from the source directory so that artifact that are already - present in the source directory are not re-computed. +and setup_copy_rules t ~ctx_dir ~non_target_source_files = + Pset.iter non_target_source_files ~f:(fun path -> + let ctx_path = Path.append ctx_dir path in + let build = Build.copy ~src:path ~dst:ctx_path in + (* We temporarily allow overrides while setting up copy rules from + the source directory so that artifact that are already present + in the source directory are not re-computed. + + This allows to keep generated files in tarballs. Maybe we + should allow it on a case-by-case basis though. *) + compile_rule t (Pre_rule.make build) ~copy_source:true) + +and is_target t file = + Pset.mem file (load_dir t ~dir:(Path.parent file)) + +and load_dir t ~dir = + match get_dir_status t ~dir with + | Loaded targets -> targets + + | Forward dir' -> + ignore (load_dir t ~dir:dir' : Pset.t); + begin match get_dir_status t ~dir with + | Loaded targets -> targets + | _ -> assert false + end + + | Collecting_rules collector -> + let lazy_generators = + match collector.stage with + | Loading -> + die "recursive dependency between directories:\n %s" + (String.concat ~sep:"\n--> " + (List.map t.load_dir_stack ~f:Utils.describe_target)) + | Pending { lazy_generators } -> + collector.stage <- Loading; + lazy_generators + in + + collector.stage <- Loading; + t.load_dir_stack <- dir :: t.load_dir_stack; + List.iter lazy_generators ~f:(fun f -> f ()); + + let context_name, sub_dir = Option.value_exn (Path.extract_build_context dir) in + + (* Load all the rules *) + let extra_subdirs_to_keep = + if context_name = "install" then + These String_set.empty + else + let gen_rules = Option.value_exn (String_map.find context_name t.gen_rules) in + gen_rules ~dir (Option.value_exn (Path.explode sub_dir)) + in + let rules = collector.rules in + + (* Compute alias rules *) + let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in + let alias_rules, alias_stamp_files = + let open Build.O in + String_map.fold collector.aliases ~init:([], Pset.empty) + ~f:(fun ~key:name ~data:{ Dir_status. deps; actions } (rules, alias_stamp_files) -> + let base_path = Path.relative alias_dir name in + let rules, deps = + List.fold_left actions ~init:(rules, deps) + ~f:(fun (rules, deps) { Dir_status. stamp; action; locks } -> + let path = Path.extend_basename base_path ~suffix:("-" ^ Digest.to_hex stamp) in + let rule = + Pre_rule.make ~locks + (Build.progn [ action; Build.create_file path ]) + in + (rule :: rules, Pset.add path deps)) + in + let path = Path.extend_basename base_path ~suffix:Alias0.suffix in + (Pre_rule.make + (Build.path_set deps >>> + Build.action ~targets:[path] + (Redirect (Stdout, + path, + Digest_files + (Path.Set.elements deps)))) + :: rules, + Pset.add path alias_stamp_files)) + in + Hashtbl.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); + + (* Compute the set of targets and files to copy *) + let user_rule_targets, to_promote = + List.fold_left rules ~init:(Pset.empty, Pset.empty) + ~f:(fun (acc, acc_to_promote) { Pre_rule.targets; mode; _ } -> + let targets = Build_interpret.Target.paths targets in + (Pset.union targets acc, + match mode with + | Promote | Promote_but_delete_on_clean -> + Pset.union targets acc_to_promote + | _ -> + acc_to_promote)) + in + let to_promote = + Pset.map to_promote ~f:(fun p -> + Option.value_exn (Path.drop_build_context p)) + in + + (* Take into account the source files *) + let targets, to_copy, subdirs_to_keep = + match context_name with + | "install" -> + (user_rule_targets, + None, + String_set.empty) + | ctx_name -> + (* This condition is [true] because of [get_dir_status] *) + assert (String_map.mem ctx_name t.contexts); + let files, subdirs = + match File_tree.find_dir t.file_tree sub_dir with + | None -> (Pset.empty, String_set.empty) + | Some dir -> + (File_tree.Dir.file_paths dir, + File_tree.Dir.sub_dir_names dir) + in + let files = Pset.diff files to_promote in + if Pset.is_empty files then + (user_rule_targets, None, subdirs) + else + let ctx_path = Path.(relative build_dir) context_name in + (Pset.union user_rule_targets + (Pset.map files ~f:(Path.append ctx_path)), + Some (ctx_path, files), + subdirs) + in + let subdirs_to_keep = + match extra_subdirs_to_keep with + | All -> All + | These set -> These (String_set.union subdirs_to_keep set) + in + + (* Filter out fallback rules *) + let rules = + match to_copy with + | None -> + (* If there are no source files to copy, fallback rules are + automatically kept *) + rules + | Some (_, to_copy) -> + List.filter rules ~f:(fun (rule : Build_interpret.Rule.t) -> + match rule.mode with + | Standard | Promote | Promote_but_delete_on_clean + | Not_a_rule_stanza -> true + | Fallback -> + let source_files_for_targtes = + List.fold_left rule.targets ~init:Pset.empty + ~f:(fun acc target -> + Pset.add + (Build_interpret.Target.path target + |> Path.drop_build_context + (* All targets are in [dir] and we know it correspond to a directory + of a build context since there are source files to copy, so this + call can't fail. *) + |> Option.value_exn) + acc) + in + if Pset.subset source_files_for_targtes to_copy then + (* All targets are present *) + false + else begin + if Pset.is_empty (Pset.inter source_files_for_targtes to_copy) then + (* No target is present *) + true + else begin + let absent_targets = + Pset.diff source_files_for_targtes to_copy + in + let present_targets = + Pset.diff source_files_for_targtes absent_targets + in + Loc.fail + (rule_loc ~loc:rule.loc + ~dir:(Path.drop_optional_build_context dir)) + "\ +Some of the targets of this fallback rule are present in the source tree, +and some are not. This is not allowed. Either none of the targets must +be present in the source tree, either they must all be. + +The following targets are present: +%s + +The following targets are not: +%s +" + (string_of_paths present_targets) + (string_of_paths absent_targets) + end + end) + in + + (* Set the directory status to loaded *) + Hashtbl.replace t.dirs ~key:dir ~data:(Loaded targets); + (match t.load_dir_stack with + | [] -> assert false + | x :: l -> + t.load_dir_stack <- l; + assert (x = dir)); + + (* Compile the rules and cleanup stale artifacts *) + List.iter rules ~f:(compile_rule t ~copy_source:false); + Option.iter to_copy ~f:(fun (ctx_dir, source_files) -> + setup_copy_rules t ~ctx_dir ~non_target_source_files:source_files); + remove_old_artifacts t ~dir ~subdirs_to_keep; + + List.iter alias_rules ~f:(compile_rule t ~copy_source:false); + remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep; + + targets + +and load_dir_unit t ~dir = ignore (load_dir t ~dir : Pset.t) + +and wait_for_file t fn ~targeting = + match Hashtbl.find t.files fn with + | Some file -> wait_for_file_found t fn file ~targeting + | None -> + let dir = Path.parent fn in + if Path.is_in_build_dir dir then begin + load_dir_unit t ~dir; + match Hashtbl.find t.files fn with + | Some file -> wait_for_file_found t fn file ~targeting + | None -> no_rule_found t fn + end else if Path.exists fn then + return () + else + die "File unavailable: %s" (Path.to_string_maybe_quoted fn) + +and wait_for_file_found t fn (File_spec.T file) ~targeting = + match file.rule.exec with + | Not_started { eval_rule; exec_rule } -> + file.rule.exec <- Starting { for_file = targeting }; + let rule_evaluation = + wrap_build_errors t ~targeting:fn ~f:eval_rule + in + let rule_execution = + wrap_build_errors t ~targeting:fn ~f:(exec_rule rule_evaluation) + in + file.rule.exec <- + Running { for_file = targeting + ; rule_evaluation + ; rule_execution + }; + rule_execution + | Running { rule_execution; _ } -> rule_execution + | Evaluating_rule { for_file; rule_evaluation; exec_rule } -> + file.rule.exec <- Starting { for_file = targeting }; + let rule_execution = + wrap_build_errors t ~targeting:fn ~f:(exec_rule rule_evaluation) + in + file.rule.exec <- + Running { for_file + ; rule_evaluation + ; rule_execution + }; + rule_execution + | Starting _ -> + (* Recursive deps! *) + let rec build_loop acc targeting = + let acc = targeting :: acc in + if fn = targeting then + acc + else + let (File_spec.T file) = find_file_exn t targeting in + match file.rule.exec with + | Not_started _ | Running _ | Evaluating_rule _ -> assert false + | Starting { for_file } -> + build_loop acc for_file + in + let loop = build_loop [fn] targeting in + die "Dependency cycle between the following files:\n %s" + (String.concat ~sep:"\n--> " + (List.map loop ~f:Path.to_string)) + +and wait_for_deps t deps ~targeting = + all_unit + (Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc)) + +let targets_of = load_dir +let load_dir = load_dir_unit + +let stamp_file_for_files_of t ~dir ~ext = + let files_of_dir = + Hashtbl.find_or_add t.files_of dir ~f:(fun dir -> + let files_by_ext = + targets_of t ~dir + |> Path.Set.elements + |> List.map ~f:(fun fn -> Filename.extension (Path.to_string fn), fn) + |> String_map.of_alist_multi + in + { files_by_ext + ; dir_hash = Path.to_string dir |> Digest.string |> Digest.to_hex + ; stamps = String_map.empty + }) + in + match String_map.find ext files_of_dir.stamps with + | Some fn -> fn + | None -> + let stamp_file = Path.relative misc_dir (files_of_dir.dir_hash ^ ext) in + let files = + Option.value + (String_map.find ext files_of_dir.files_by_ext) + ~default:[] + in + compile_rule t + (let open Build.O in + Pre_rule.make + (Build.paths files >>> + Build.action ~targets:[stamp_file] + (Action.with_stdout_to stamp_file + (Action.digest_files files)))); + files_of_dir.stamps <- String_map.add files_of_dir.stamps ~key:ext ~data:stamp_file; + stamp_file - This allows to keep generated files in tarballs. Maybe we - should allow it on a case-by-case basis though. *) - compile_rule t (Pre_rule.make build) - ~all_targets_by_dir - ~copy_source:true)) module Trace = struct type t = (Path.t, Digest.t) Hashtbl.t @@ -596,138 +1081,43 @@ module Trace = struct trace end -let all_targets_ever_built () = - if Sys.file_exists Trace.file then - let trace = Trace.load () in - Hashtbl.fold trace ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) - else - [] +let all_targets t = + String_map.iter t.contexts ~f:(fun ~key:_ ~data:ctx -> + File_tree.fold t.file_tree ~traverse_ignored_dirs:true ~init:() ~f:(fun dir () -> + load_dir_unit t ~dir:(Path.append ctx.Context.build_dir (File_tree.Dir.path dir)))); + Hashtbl.fold t.files ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) -let dump_trace t = Trace.dump t.trace +let finalize t = + Promoted_to_delete.dump (); + Trace.dump t.trace; + Action.Promotion.finalize () -let create ~contexts ~file_tree ~rules = - let all_source_files = - File_tree.fold file_tree ~init:Pset.empty ~traverse_ignored_dirs:true - ~f:(fun dir acc -> - let path = File_tree.Dir.path dir in - Pset.union acc - (File_tree.Dir.files dir - |> String_set.elements - |> List.map ~f:(Path.relative path) - |> Pset.of_list)) +let create ~contexts ~file_tree = + let contexts = + List.map contexts ~f:(fun c -> (c.Context.name, c)) + |> String_map.of_alist_exn in - let all_copy_targets = - List.fold_left contexts ~init:Pset.empty ~f:(fun acc (ctx : Context.t) -> - Pset.union acc (Pset.elements all_source_files - |> List.map ~f:(Path.append ctx.build_dir) - |> Pset.of_list)) - in - let all_other_targets = - List.fold_left rules ~init:Pset.empty ~f:(fun acc { Pre_rule.targets; _ } -> - List.fold_left targets ~init:acc ~f:(fun acc target -> - Pset.add (Target.path target) acc)) - in - let all_targets_by_dir = lazy ( - Pset.elements (Pset.union all_copy_targets all_other_targets) - |> List.filter_map ~f:(fun path -> - if Path.is_root path then - None - else - Some (Path.parent path, path)) - |> Pmap.of_alist_multi - |> Pmap.map ~f:Pset.of_list - ) in let t = { contexts ; files = Hashtbl.create 1024 ; trace = Trace.load () ; local_mkdirs = Path.Local.Set.empty - ; all_targets_by_dir - } in - List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~copy_source:false); - setup_copy_rules t ~all_targets_by_dir - ~all_non_target_source_files: - (Pset.diff all_source_files all_other_targets); - - (let l = !disabled_fallback_rules in - disabled_fallback_rules := []; - List.iter l ~f:(fun rule -> - let disabled_for = - match rule.Internal_rule.fallback with - | No | Not_possible -> assert false - | Yes paths -> paths - in - let leftover_targets = Pset.diff rule.targets disabled_for in - if not (Pset.is_empty leftover_targets) then begin - let list_paths set = - Pset.elements set - |> List.map ~f:(fun p -> sprintf "- %s" - (Path.to_string_maybe_quoted - (Path.drop_optional_build_context p))) - |> String.concat ~sep:"\n" - in - Loc.fail (Internal_rule.loc rule ~dir:(Path.parent (Pset.choose leftover_targets))) - "\ -Some of the targets of this fallback rule are present in the source tree, -and some are not. This is not allowed. Either none of the targets must -be present in the source tree, either they must all be. - -The following targets are present: -%s - -The following targets are not: -%s -" - (list_paths disabled_for) - (list_paths leftover_targets) - end - )); - - at_exit (fun () -> dump_trace t); - Future.Scheduler.at_exit_after_waiting_for_commands Action.Promotion.finalize; + ; dirs = Hashtbl.create 1024 + ; load_dir_stack = [] + ; file_tree + ; gen_rules = String_map.map contexts ~f:(fun _ ~dir:_ -> die "gen_rules called too early") + ; build_dirs_to_keep = Pset.empty + ; files_of = Hashtbl.create 1024 + } + in + at_exit (fun () -> finalize t); t -let remove_old_artifacts t = - let rec walk dir = - let keep = - if Hashtbl.mem t.files (Path.relative dir Config.jbuilder_keep_fname) then - true - else begin - Path.readdir dir - |> List.filter ~f:(fun fn -> - let fn = Path.relative dir fn in - match Unix.lstat (Path.to_string fn) with - | { st_kind = S_DIR; _ } -> - walk fn - | exception _ -> - let keep = Hashtbl.mem t.files fn in - if not keep then Path.unlink fn; - keep - | _ -> - let keep = Hashtbl.mem t.files fn in - if not keep then Path.unlink fn; - keep) - |> function - | [] -> false - | _ -> true - end - in - if not keep then Path.rmdir dir; - keep - in - let walk dir = - if Path.exists dir then ignore (walk dir : bool) - in - List.iter t.contexts ~f:(fun (ctx : Context.t) -> - walk ctx.build_dir; - walk (Config.local_install_dir ~context:ctx.name); - ) - let eval_request t ~request ~process_target = let { Build_interpret.Static_deps. rule_deps ; action_deps = static_deps - } = Build_interpret.static_deps request ~all_targets_by_dir:t.all_targets_by_dir + } = Build_interpret.static_deps request ~all_targets:(targets_of t) in let process_targets ts = @@ -744,7 +1134,6 @@ let eval_request t ~request ~process_target = >>| fun ((), ()) -> () let do_build_exn t ~request = - remove_old_artifacts t; eval_request t ~request ~process_target:(fun fn -> wait_for_file t fn ~targeting:fn) @@ -758,6 +1147,7 @@ module Ir_set = Set.Make(Internal_rule) let rules_for_files t paths = List.filter_map paths ~f:(fun path -> + if Path.is_in_build_dir path then load_dir_unit t ~dir:path; match Hashtbl.find t.files path with | None -> None | Some (File_spec.T { rule; _ }) -> Some rule) @@ -791,7 +1181,7 @@ let static_deps_of_request t request = let { Build_interpret.Static_deps. rule_deps ; action_deps - } = Build_interpret.static_deps request ~all_targets_by_dir:t.all_targets_by_dir + } = Build_interpret.static_deps request ~all_targets:(targets_of t) in Pset.elements (Pset.union rule_deps action_deps) @@ -858,47 +1248,52 @@ let build_rules ?(recursive=false) t ~request = let rules_seen = ref Id_set.empty in let rules = ref [] in let rec loop fn = + let dir = Path.parent fn in + if Path.is_in_build_dir dir then load_dir t ~dir; match Hashtbl.find t.files fn with - | None -> return () - | Some (File_spec.T { rule = ir; _ }) -> - if Id_set.mem ir.id !rules_seen then - return () - else begin - rules_seen := Id_set.add ir.id !rules_seen; - let rule = - let make_rule rule_evaluation = - rule_evaluation >>| fun (action, dyn_deps) -> - { Rule. - id = ir.id - ; deps = Pset.union ir.static_deps dyn_deps - ; targets = ir.targets - ; context = ir.context - ; action = action - } - in - match ir.exec with - | Starting _ -> assert false (* guarded by [rules_seen] *) - | Running { rule_evaluation; _ } | Evaluating_rule { rule_evaluation; _ } -> - make_rule rule_evaluation - | Not_started { eval_rule; exec_rule } -> - ir.exec <- Starting { for_file = fn }; - let rule_evaluation = - wrap_build_errors t ~targeting:fn ~f:eval_rule - in - ir.exec <- - Evaluating_rule { for_file = fn - ; rule_evaluation - ; exec_rule - }; - make_rule rule_evaluation + | Some file -> + file_found fn file + | None -> + return () + and file_found fn (File_spec.T { rule = ir; _ }) = + if Id_set.mem ir.id !rules_seen then + return () + else begin + rules_seen := Id_set.add ir.id !rules_seen; + let rule = + let make_rule rule_evaluation = + rule_evaluation >>| fun (action, dyn_deps) -> + { Rule. + id = ir.id + ; deps = Pset.union ir.static_deps dyn_deps + ; targets = ir.targets + ; context = ir.context + ; action = action + } in - rules := rule :: !rules; - rule >>= fun rule -> - if recursive then - Future.all_unit (List.map (Pset.elements rule.deps) ~f:loop) - else - return () - end + match ir.exec with + | Starting _ -> assert false (* guarded by [rules_seen] *) + | Running { rule_evaluation; _ } | Evaluating_rule { rule_evaluation; _ } -> + make_rule rule_evaluation + | Not_started { eval_rule; exec_rule } -> + ir.exec <- Starting { for_file = fn }; + let rule_evaluation = + wrap_build_errors t ~targeting:fn ~f:eval_rule + in + ir.exec <- + Evaluating_rule { for_file = fn + ; rule_evaluation + ; exec_rule + }; + make_rule rule_evaluation + in + rules := rule :: !rules; + rule >>= fun rule -> + if recursive then + Future.all_unit (List.map (Pset.elements rule.deps) ~f:loop) + else + return () + end in let targets = ref Pset.empty in eval_request t ~request ~process_target:(fun fn -> @@ -921,3 +1316,85 @@ let build_rules ?(recursive=false) t ~request = die "dependency cycle detected:\n %s" (List.map cycle ~f:(fun rule -> Path.to_string (Pset.choose rule.Rule.targets)) |> String.concat ~sep:"\n-> ") + +(* +-----------------------------------------------------------------+ + | Adding rules to the system | + +-----------------------------------------------------------------+ *) + +let rec add_build_dir_to_keep t ~dir = + if not (Pset.mem dir t.build_dirs_to_keep) then begin + t.build_dirs_to_keep <- Pset.add dir t.build_dirs_to_keep; + let dir = Path.parent dir in + if dir <> Path.root then + add_build_dir_to_keep t ~dir + end + +let get_collector t ~dir = + match get_dir_status t ~dir with + | Collecting_rules collector -> + if collector.rules = [] && String_map.is_empty collector.aliases then + add_build_dir_to_keep t ~dir; + collector + | Loaded _ | Forward _ -> + Sexp.code_error + (if Path.is_in_source_tree dir then + "Build_system.get_collector called on source directory" + else if dir = Path.build_dir then + "Build_system.get_collector called on _build" + else if not (Path.is_local dir) then + "Build_system.get_collector called on external directory" + else + "Build_system.get_collector called on closed directory") + [ "dir", Path.sexp_of_t dir + ] + +let add_rule t (rule : Build_interpret.Rule.t) = + let collector = get_collector t ~dir:rule.dir in + collector.rules <- rule :: collector.rules + +let on_load_dir t ~dir ~f = + let collector = get_collector t ~dir in + match collector.stage with + | Loading -> f () + | Pending p -> + let lazy_generators = p.lazy_generators in + if lazy_generators = [] && + collector.rules = [] && + String_map.is_empty collector.aliases then + add_build_dir_to_keep t ~dir; + p.lazy_generators <- f :: lazy_generators + +let eval_glob t ~dir re = + let targets = targets_of t ~dir |> Pset.elements |> List.map ~f:Path.basename in + let files = + match File_tree.find_dir t.file_tree dir with + | None -> targets + | Some d -> + String_set.union (String_set.of_list targets) (File_tree.Dir.files d) + |> String_set.elements + in + List.filter files ~f:(Re.execp re) + +module Alias = struct + include Alias0 + + let get_alias_def build_system t = + let collector = get_collector build_system ~dir:t.dir in + match String_map.find t.name collector.aliases with + | None -> + let x = { Dir_status. deps = Pset.empty; actions = [] } in + collector.aliases <- String_map.add collector.aliases ~key:t.name ~data:x; + x + | Some x -> x + + let add_deps build_system t deps = + let def = get_alias_def build_system t in + def.deps <- Pset.union def.deps (Pset.of_list deps) + + let add_action build_system t ?(locks=[]) ~stamp action = + let def = get_alias_def build_system t in + def.actions <- { stamp = Digest.string (Sexp.to_string stamp) + ; action + ; locks + } :: def.actions +end diff --git a/src/build_system.mli b/src/build_system.mli index 1eac9030..f152154e 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -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 diff --git a/src/clflags.ml b/src/clflags.ml index d8f99df1..dca92fdf 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -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 diff --git a/src/clflags.mli b/src/clflags.mli index f0476a51..86ed6ba3 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -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 diff --git a/src/file_tree.ml b/src/file_tree.ml index b82f4379..44bb7af3 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -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 diff --git a/src/file_tree.mli b/src/file_tree.mli index 44a339a3..3559c662 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -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 diff --git a/src/future.ml b/src/future.ml index b6e12a42..28072d99 100644 --- a/src/future.ml +++ b/src/future.ml @@ -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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index e0e699d4..54748014 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -12,11 +12,17 @@ module type Params = sig end module Gen(P : Params) = struct + module Alias = Build_system.Alias module SC = Super_context open P let ctx = SC.context sctx + let stanzas_per_dir = + List.map (SC.stanzas sctx) ~f:(fun stanzas -> + (stanzas.SC.Dir_with_jbuild.ctx_dir, stanzas)) + |> Path.Map.of_alist_exn + (* +-----------------------------------------------------------------+ | Interpretation of [modules] fields | +-----------------------------------------------------------------+ *) @@ -38,6 +44,261 @@ module Gen(P : Params) = struct String_map.filter all_modules ~f:(fun unit _ -> String_set.mem unit units) end + (* +-----------------------------------------------------------------+ + | User rules & copy files | + +-----------------------------------------------------------------+ *) + + let interpret_locks ~dir ~scope locks = + List.map locks ~f:(fun s -> + Path.relative dir (SC.expand_vars sctx ~dir ~scope s)) + + let user_rule (rule : Rule.t) ~dir ~scope = + let targets : SC.Action.targets = + match rule.targets with + | Infer -> Infer + | Static fns -> Static (List.map fns ~f:(Path.relative dir)) + in + SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc + ~locks:(interpret_locks ~dir ~scope rule.locks) + (SC.Deps.interpret sctx ~scope ~dir rule.deps + >>> + SC.Action.run + sctx + rule.action + ~dir + ~dep_kind:Required + ~targets + ~scope) + + let copy_files_rules (def: Copy_files.t) ~src_dir ~dir ~scope = + let loc = String_with_vars.loc def.glob in + let glob_in_src = + let src_glob = SC.expand_vars sctx ~dir def.glob ~scope in + Path.relative src_dir src_glob ~error_loc:loc + in + (* The following condition is required for merlin to work. + Additionally, the order in which the rules are evaluated only + ensures that [sources_and_targets_known_so_far] returns the + right answer for sub-directories only. *) + if not (Path.is_descendant glob_in_src ~of_:src_dir) then + Loc.fail loc "%s is not a sub-directory of %s" + (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); + let glob = Path.basename glob_in_src in + let src_in_src = Path.parent glob_in_src in + let re = + match Glob_lexer.parse_string glob with + | Ok re -> + Re.compile re + | Error (_pos, msg) -> + Loc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg + in + (* add rules *) + let src_in_build = Path.append ctx.build_dir src_in_src in + let files = SC.eval_glob sctx ~dir:src_in_build re in + List.map files ~f:(fun basename -> + let file_src = Path.relative src_in_build basename in + let file_dst = Path.relative dir basename in + SC.add_rule sctx + ((if def.add_line_directive + then Build.copy_and_add_line_directive + else Build.copy) + ~src:file_src + ~dst:file_dst); + file_dst) + + (* +-----------------------------------------------------------------+ + | "text" file listing | + +-----------------------------------------------------------------+ *) + + (* Compute the list of "text" files (.ml, .c, ...). This is the list + of source files + user generated ones. As a side-effect, setup + user rules and copy_files rules. *) + let text_files = + let cache = Hashtbl.create 32 in + fun ~dir -> + Hashtbl.find_or_add cache dir ~f:(fun dir -> + match Path.Map.find dir stanzas_per_dir with + | None -> String_set.empty + | Some { stanzas; src_dir; scope; _ } -> + (* Interpret a few stanzas in order to determine the list of + files generated by the user. *) + let generated_files = + List.concat_map stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Rule rule -> + List.map (user_rule rule ~dir ~scope) ~f:Path.basename + | Copy_files def -> + List.map (copy_files_rules def ~src_dir ~dir ~scope) ~f:Path.basename + | Library { buildable; _ } | Executables { buildable; _ } -> + (* Manually add files generated by the (select ...) + dependencies *) + List.filter_map buildable.libraries ~f:(fun dep -> + match (dep : Jbuild.Lib_dep.t) with + | Direct _ -> None + | Select s -> Some s.result_fn) + | Alias _ | Provides _ | Install _ -> []) + |> String_set.of_list + in + String_set.union generated_files (SC.source_files sctx ~src_path:src_dir)) + + (* +-----------------------------------------------------------------+ + | Modules listing | + +-----------------------------------------------------------------+ *) + + let ml_of_mli : _ format = +{|(with-stdout-to %s + (progn + (echo "[@@@warning \"-a\"]\nmodule rec HACK : sig\n") + (cat %s) + (echo "\nend = HACK\ninclude HACK\n")))|} + + let re_of_rei : _ format = +{|(with-stdout-to %s + (progn + (echo "[@@@warning \"-a\"];\nmodule type HACK = {\n") + (cat %s) + (echo "\n};\nmodule rec HACK : HACK = HACK;\ninclude HACK;\n")))|} + + let no_impl_warning : _ format = + {|@{Warning@}: Module %s in %s doesn't have a corresponding .%s file. +Modules without an implementation are not recommended, see this discussion: + + https://github.com/janestreet/jbuilder/issues/9 + +In the meantime I'm implicitely adding this rule: + +(rule %s) + +Add it to your jbuild file to remove this warning. +|} + + let guess_modules ~dir ~files = + let impl_files, intf_files = + String_set.elements files + |> List.filter_map ~f:(fun fn -> + (* we aren't using Filename.extension because we want to handle + filenames such as foo.cppo.ml *) + match String.lsplit2 fn ~on:'.' with + | Some (_, "ml") -> Some (Inl { Module.File.syntax=OCaml ; name=fn }) + | Some (_, "re") -> Some (Inl { Module.File.syntax=Reason ; name=fn }) + | Some (_, "mli") -> Some (Inr { Module.File.syntax=OCaml ; name=fn }) + | Some (_, "rei") -> Some (Inr { Module.File.syntax=Reason ; name=fn }) + | _ -> None) + |> List.partition_map ~f:(fun x -> x) in + let parse_one_set files = + List.map files ~f:(fun (f : Module.File.t) -> + (String.capitalize_ascii (Filename.chop_extension f.name), f)) + |> String_map.of_alist + |> function + | Ok x -> x + | Error (name, f1, f2) -> + die "too many files for module %s in %s: %s and %s" + name (Path.to_string dir) f1.name f2.name + in + let impls = parse_one_set impl_files in + let intfs = parse_one_set intf_files in + let setup_intf_only name (intf : Module.File.t) = + let impl_fname = String.sub intf.name ~pos:0 ~len:(String.length intf.name - 1) in + let action_str = + sprintf + (match intf.syntax with + | OCaml -> ml_of_mli + | Reason -> re_of_rei) + impl_fname intf.name + in + Format.eprintf no_impl_warning + name (Path.to_string dir) + (match intf.syntax with + | OCaml -> "ml" + | Reason -> "re") + action_str; + let dir = Path.append ctx.build_dir dir in + let action = + Usexp.parse_string action_str + ~fname:"" + ~mode:Single + |> Action.Unexpanded.t + in + SC.add_rule sctx + (Build.return [] + >>> + SC.Action.run sctx action + ~dir + ~dep_kind:Required + ~targets:Infer + ~scope:Scope.empty); + { intf with name = impl_fname } in + String_map.merge impls intfs ~f:(fun name impl intf -> + let impl = + match impl with + | None -> setup_intf_only name (Option.value_exn intf) + | Some i -> i in + Some + { Module.name + ; impl + ; intf + ; obj_name = "" } + ) + + let modules_by_dir = + let cache = Hashtbl.create 32 in + fun ~dir -> + Hashtbl.find_or_add cache dir ~f:(fun dir -> + let files = text_files ~dir in + guess_modules ~dir ~files) + + type modules_by_lib = + { modules : Module.t String_map.t + ; alias_module : Module.t option + ; main_module_name : string + } + + let modules_by_lib = + let cache = Hashtbl.create 32 in + fun (lib : Library.t) ~dir -> + Hashtbl.find_or_add cache (dir, lib.name) ~f:(fun _ -> + let all_modules = modules_by_dir ~dir in + let modules = + parse_modules ~dir ~all_modules ~modules_written_by_user:lib.buildable.modules + in + let main_module_name = String.capitalize_ascii lib.name in + let modules = + String_map.map modules ~f:(fun (m : Module.t) -> + if not lib.wrapped || m.name = main_module_name then + { m with obj_name = Utils.obj_name_of_basename m.impl.name } + else + { m with obj_name = sprintf "%s__%s" lib.name m.name }) + in + let alias_module = + if not lib.wrapped || + (String_map.cardinal modules = 1 && + String_map.mem main_module_name modules) then + None + else + let suf = + if String_map.mem main_module_name modules then + "__" + else + "" + in + Some + { Module.name = main_module_name ^ suf + ; impl = { name = lib.name ^ suf ^ ".ml-gen" ; syntax = OCaml } + ; intf = None + ; obj_name = lib.name ^ suf + } + in + { modules; alias_module; main_module_name }) + + let module_names_of_lib lib ~dir = + let { modules; alias_module; _ } = modules_by_lib lib ~dir in + let modules = + match alias_module with + | None -> modules + | Some m -> String_map.add modules ~key:m.name ~data:m + in + String_map.values modules + (* +-----------------------------------------------------------------+ | Library stuff | +-----------------------------------------------------------------+ *) @@ -175,60 +436,16 @@ module Gen(P : Params) = struct ]); dst - (* Hack for the install file *) - let modules_by_lib : (string, Module.t list) Hashtbl.t = Hashtbl.create 32 - (* In 4.02, the compiler reads the cmi for module alias even with [-w -49 -no-alias-deps], so we must sandbox the build of the alias module since the modules it references are built after. *) let alias_module_build_sandbox = Scanf.sscanf ctx.version "%u.%u" (fun a b -> a, b) <= (4, 02) - let library_rules (lib : Library.t) ~dir ~all_modules ~files ~scope = + let library_rules (lib : Library.t) ~dir ~files ~scope = let dep_kind = if lib.optional then Build.Optional else Required in let flags = Ocaml_flags.make lib.buildable sctx ~scope ~dir in - let modules = - parse_modules ~dir ~all_modules ~modules_written_by_user:lib.buildable.modules - in - let main_module_name = String.capitalize_ascii lib.name in - let modules = - String_map.map modules ~f:(fun (m : Module.t) -> - if not lib.wrapped || m.name = main_module_name then - { m with obj_name = Utils.obj_name_of_basename m.impl.name } - else - { m with obj_name = sprintf "%s__%s" lib.name m.name }) - in - let alias_module = - if not lib.wrapped || - (String_map.cardinal modules = 1 && - String_map.mem main_module_name modules) then - None - else - let suf = - if String_map.mem main_module_name modules then - "__" - else - "" - in - Some - { Module.name = main_module_name ^ suf - ; impl = { name = lib.name ^ suf ^ ".ml-gen" ; syntax = OCaml } - ; intf = None - ; obj_name = lib.name ^ suf - } - in - (* Add the modules before preprocessing, otherwise the install rules are going to pick - up the pre-processed modules *) - Hashtbl.add modules_by_lib - ~key:lib.name - ~data:( - let modules = - match alias_module with - | None -> modules - | Some m -> String_map.add modules ~key:m.name ~data:m - in - String_map.values modules); - + let { modules; main_module_name; alias_module } = modules_by_lib ~dir lib in (* Preprocess before adding the alias module as it doesn't need preprocessing *) let modules = SC.PP.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope @@ -548,35 +765,12 @@ module Gen(P : Params) = struct } (* +-----------------------------------------------------------------+ - | User rules | + | Aliases | +-----------------------------------------------------------------+ *) - let interpret_locks ~dir ~scope locks = - List.map locks ~f:(fun s -> - Path.relative dir (SC.expand_vars sctx ~dir ~scope s)) - - let user_rule (rule : Rule.t) ~dir ~scope = - let targets : SC.Action.targets = - match rule.targets with - | Infer -> Infer - | Static fns -> Static (List.map fns ~f:(Path.relative dir)) - in - SC.add_rule sctx ~fallback:rule.fallback ~loc:rule.loc - ~locks:(interpret_locks ~dir ~scope rule.locks) - (SC.Deps.interpret sctx ~scope ~dir rule.deps - >>> - SC.Action.run - sctx - rule.action - ~dir - ~dep_kind:Required - ~targets - ~scope) - let add_alias ~dir ~name ~stamp ?(locks=[]) build = - let alias = Alias.make name ~dir in - SC.add_rule sctx ~locks - (Alias.add_build (SC.aliases sctx) alias ~stamp build) + let alias = Build_system.Alias.make name ~dir in + SC.add_alias_action sctx alias ~locks ~stamp build let alias_rules (alias_conf : Alias_conf.t) ~dir ~scope = let stamp = @@ -605,195 +799,38 @@ module Gen(P : Params) = struct ~targets:(Static []) ~scope) - let copy_files_rules (def: Copy_files.t) ~src_dir ~dir ~scope = - let loc = String_with_vars.loc def.glob in - let glob_in_src = - let src_glob = SC.expand_vars sctx ~dir def.glob ~scope in - Path.relative src_dir src_glob ~error_loc:loc - in - (* The following condition is required for merlin to work. - Additionally, the order in which the rules are evaluated only - ensures that [sources_and_targets_known_so_far] returns the - right answer for sub-directories only. *) - if not (Path.is_descendant glob_in_src ~of_:src_dir) then - Loc.fail loc "%s is not a sub-directory of %s" - (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); - let glob = Path.basename glob_in_src in - let src_in_src = Path.parent glob_in_src in - let re = - match Glob_lexer.parse_string glob with - | Ok re -> - Re.compile re - | Error (_pos, msg) -> - Loc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg - in - (* add rules *) - let files = SC.sources_and_targets_known_so_far sctx ~src_path:src_in_src in - let src_in_build = Path.append ctx.build_dir src_in_src in - String_set.iter files ~f:(fun basename -> - let matches = Re.execp re basename in - if matches then - let file_src = Path.relative src_in_build basename in - let file_dst = Path.relative dir basename in - SC.add_rule sctx - ((if def.add_line_directive - then Build.copy_and_add_line_directive - else Build.copy) - ~src:file_src - ~dst:file_dst) - ); - { Merlin.requires = Build.return [] - ; flags = Build.return [] - ; preprocess = Jbuild.Preprocess.No_preprocessing - ; libname = None - ; source_dirs = Path.Set.singleton src_in_src - } - - - (* +-----------------------------------------------------------------+ - | Modules listing | - +-----------------------------------------------------------------+ *) - - let ml_of_mli : _ format = -{|(with-stdout-to %s - (progn - (echo "[@@@warning \"-a\"]\nmodule rec HACK : sig\n") - (cat %s) - (echo "\nend = HACK\ninclude HACK\n")))|} - - let re_of_rei : _ format = -{|(with-stdout-to %s - (progn - (echo "[@@@warning \"-a\"];\nmodule type HACK = {\n") - (cat %s) - (echo "\n};\nmodule rec HACK : HACK = HACK;\ninclude HACK;\n")))|} - - let no_impl_warning : _ format = - {|@{Warning@}: Module %s in %s doesn't have a corresponding .%s file. -Modules without an implementation are not recommended, see this discussion: - - https://github.com/janestreet/jbuilder/issues/9 - -In the meantime I'm implicitely adding this rule: - -(rule %s) - -Add it to your jbuild file to remove this warning. -|} - - let guess_modules ~dir ~files = - let impl_files, intf_files = - String_set.elements files - |> List.filter_map ~f:(fun fn -> - (* we aren't using Filename.extension because we want to handle - filenames such as foo.cppo.ml *) - match String.lsplit2 fn ~on:'.' with - | Some (_, "ml") -> Some (Inl { Module.File.syntax=OCaml ; name=fn }) - | Some (_, "re") -> Some (Inl { Module.File.syntax=Reason ; name=fn }) - | Some (_, "mli") -> Some (Inr { Module.File.syntax=OCaml ; name=fn }) - | Some (_, "rei") -> Some (Inr { Module.File.syntax=Reason ; name=fn }) - | _ -> None) - |> List.partition_map ~f:(fun x -> x) in - let parse_one_set files = - List.map files ~f:(fun (f : Module.File.t) -> - (String.capitalize_ascii (Filename.chop_extension f.name), f)) - |> String_map.of_alist - |> function - | Ok x -> x - | Error (name, f1, f2) -> - die "too many files for module %s in %s: %s and %s" - name (Path.to_string dir) f1.name f2.name - in - let impls = parse_one_set impl_files in - let intfs = parse_one_set intf_files in - let setup_intf_only name (intf : Module.File.t) = - let impl_fname = String.sub intf.name ~pos:0 ~len:(String.length intf.name - 1) in - let action_str = - sprintf - (match intf.syntax with - | OCaml -> ml_of_mli - | Reason -> re_of_rei) - impl_fname intf.name - in - Format.eprintf no_impl_warning - name (Path.to_string dir) - (match intf.syntax with - | OCaml -> "ml" - | Reason -> "re") - action_str; - let dir = Path.append ctx.build_dir dir in - let action = - Usexp.parse_string action_str - ~fname:"" - ~mode:Single - |> Action.Unexpanded.t - in - SC.add_rule sctx - (Build.return [] - >>> - SC.Action.run sctx action - ~dir - ~dep_kind:Required - ~targets:Infer - ~scope:Scope.empty); - { intf with name = impl_fname } in - String_map.merge impls intfs ~f:(fun name impl intf -> - let impl = - match impl with - | None -> setup_intf_only name (Option.value_exn intf) - | Some i -> i in - Some - { Module.name - ; impl - ; intf - ; obj_name = "" } - ) - (* +-----------------------------------------------------------------+ | Stanza | +-----------------------------------------------------------------+ *) - let rules { SC.Dir_with_jbuild. src_dir; ctx_dir; stanzas; scope } = - (* Interpret user rules and other simple stanzas first in order to populate the known - target table, which is needed for guessing the list of modules. *) - let merlins = - List.filter_map stanzas ~f:(fun stanza -> - let dir = ctx_dir in - match (stanza : Stanza.t) with - | Rule rule -> user_rule rule ~dir ~scope; None - | Alias alias -> alias_rules alias ~dir ~scope; None - | Copy_files def -> - Some (copy_files_rules def ~src_dir ~dir ~scope) - | Library _ | Executables _ | Provides _ | Install _ -> None) - in - let files = lazy ( - let files = SC.sources_and_targets_known_so_far sctx ~src_path:src_dir in - (* Manually add files generated by the (select ...) dependencies since we haven't - interpreted libraries and executables yet. *) - List.fold_left stanzas ~init:files ~f:(fun acc stanza -> - match (stanza : Stanza.t) with - | Library { buildable; _ } | Executables { buildable; _ } -> - List.fold_left buildable.libraries ~init:acc ~f:(fun acc dep -> - match (dep : Jbuild.Lib_dep.t) with - | Direct _ -> acc - | Select s -> String_set.add s.result_fn acc) - | _ -> acc) - ) in - let all_modules = lazy ( - guess_modules ~dir:src_dir - ~files:(Lazy.force files)) - in - List.fold_left stanzas ~init:merlins ~f:(fun merlins stanza -> + let gen_rules { SC.Dir_with_jbuild. src_dir; ctx_dir; stanzas; scope } = + (* This interprets "rule" and "copy_files" stanzas. *) + let files = text_files ~dir:ctx_dir in + let all_modules = modules_by_dir ~dir:ctx_dir in + List.filter_map stanzas ~f:(fun stanza -> let dir = ctx_dir in match (stanza : Stanza.t) with | Library lib -> - library_rules lib ~dir ~all_modules:(Lazy.force all_modules) - ~files:(Lazy.force files) ~scope - :: merlins + Some (library_rules lib ~dir ~files ~scope) | Executables exes -> - executables_rules exes ~dir ~all_modules:(Lazy.force all_modules) ~scope - :: merlins - | _ -> merlins) + Some (executables_rules exes ~dir ~all_modules ~scope) + | Alias alias -> + alias_rules alias ~dir ~scope; + None + | Copy_files { glob; _ } -> + let src_dir = + let loc = String_with_vars.loc glob in + let src_glob = SC.expand_vars sctx ~dir glob ~scope in + Path.parent (Path.relative src_dir src_glob ~error_loc:loc) + in + Some + { Merlin.requires = Build.return [] + ; flags = Build.return [] + ; preprocess = Jbuild.Preprocess.No_preprocessing + ; libname = None + ; source_dirs = Path.Set.singleton src_dir + } + | _ -> None) |> Merlin.merge_all |> Option.map ~f:(fun (m : Merlin.t) -> { m with source_dirs = @@ -806,118 +843,78 @@ Add it to your jbuild file to remove this warning. Utop.add_module_rules sctx ~dir merlin.requires; ) - let () = - (* Sort the list of stanzas by directory so that we traverse - subdirectories first. - - This is required for correctly interpreting [copy_files]. *) - let subtree_smaller x y = - Path.compare y.SC.Dir_with_jbuild.src_dir x.SC.Dir_with_jbuild.src_dir in - let stanzas = List.sort ~cmp:subtree_smaller (SC.stanzas sctx) in - List.iter stanzas ~f:rules - let () = - SC.add_rules sctx (Js_of_ocaml_rules.setup_separate_compilation_rules sctx) - let () = Odoc.setup_css_rule sctx - let () = Odoc.setup_toplevel_index_rule sctx - (* +-----------------------------------------------------------------+ | META | +-----------------------------------------------------------------+ *) - (* The rules for META files must come after the interpretation of the jbuild stanzas - since a user rule might generate a META. file *) - - (* META files that must be installed. Either because there is an explicit or user - generated one, or because *) - let packages_with_explicit_or_user_generated_meta = + let init_meta () = String_map.values (SC.packages sctx) - |> List.filter_map ~f:(fun (pkg : Package.t) -> + |> List.iter ~f:(fun (pkg : Package.t) -> let path = Path.append ctx.build_dir pkg.path in - let meta_fn = "META." ^ pkg.name in - let meta_templ_fn = meta_fn ^ ".template" in + SC.on_load_dir sctx ~dir:path ~f:(fun () -> + let meta_fn = "META." ^ pkg.name in - let files = - SC.sources_and_targets_known_so_far sctx ~src_path:pkg.path - in - let has_meta, has_meta_tmpl = - (String_set.mem meta_fn files, - String_set.mem meta_templ_fn files) - in + let meta_template = Path.relative path (meta_fn ^ ".template" ) in + let meta = Path.relative path meta_fn in - let meta_fn = - if has_meta then - meta_fn ^ ".from-jbuilder" - else - meta_fn - in - let meta_path = Path.relative path meta_fn in - - let version = - let get = - match pkg.version_from_opam_file with - | Some s -> Build.return (Some s) - | None -> - let rec loop = function - | [] -> Build.return None - | candidate :: rest -> - let p = Path.relative path candidate in - Build.if_file_exists p - ~then_:(Build.lines_of p - >>^ function - | ver :: _ -> Some ver - | _ -> Some "") - ~else_:(loop rest) - in - loop - [ pkg.name ^ ".version" - ; "version" - ; "VERSION" - ] + let version = + let get = + match pkg.version_from_opam_file with + | Some s -> Build.return (Some s) + | None -> + let rec loop = function + | [] -> Build.return None + | candidate :: rest -> + let p = Path.relative path candidate in + Build.if_file_exists p + ~then_:(Build.lines_of p + >>^ function + | ver :: _ -> Some ver + | _ -> Some "") + ~else_:(loop rest) + in + loop + [ pkg.name ^ ".version" + ; "version" + ; "VERSION" + ] + in + Super_context.Pkg_version.set sctx pkg get in - Super_context.Pkg_version.set sctx pkg get - in - let template = - if has_meta_tmpl then - let meta_templ_path = Path.relative path meta_templ_fn in - Build.lines_of meta_templ_path - else - Build.return ["# JBUILDER_GEN"] - in - let meta = - version >>^ fun version -> - Gen_meta.gen ~package:pkg.name - ~version - ~stanzas:(SC.stanzas_to_consider_for_install sctx) - ~resolve_lib_dep_names:(SC.Libs.best_lib_dep_names_exn sctx) - in - SC.add_rule sctx - (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.extract_blank_separated_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.write_file_dyn meta_path); - - if has_meta || has_meta_tmpl then - Some pkg.name - else - None) - |> String_set.of_list + let template = + Build.if_file_exists meta_template + ~then_:(Build.lines_of meta_template) + ~else_:(Build.return ["# JBUILDER_GEN"]) + in + let meta_contents = + version >>^ fun version -> + Gen_meta.gen ~package:pkg.name + ~version + ~stanzas:(SC.stanzas_to_consider_for_install sctx) + ~resolve_lib_dep_names:(SC.Libs.best_lib_dep_names_exn sctx) + in + SC.add_rule sctx + (Build.fanout meta_contents 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.extract_blank_separated_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.write_file_dyn meta))) (* +-----------------------------------------------------------------+ | Installation | @@ -931,13 +928,7 @@ Add it to your jbuild file to remove this warning. let { Mode.Dict. byte; native } = lib.modes in let if_ cond l = if cond then l else [] in let files = - let modules = - Hashtbl.find_exn modules_by_lib lib.name - ~string_of_key:(sprintf "%S") - ~table_desc:(fun _ -> - sprintf "" - (Path.to_string ctx.build_dir)) - in + let modules = module_names_of_lib lib ~dir in List.concat [ List.concat_map modules ~f:(fun m -> List.concat @@ -985,10 +976,7 @@ Add it to your jbuild file to remove this warning. else pps in - let ppx_exe = - SC.PP.get_ppx_driver sctx pps - ~dir ~dep_kind:(if lib.optional then Build.Optional else Required) - in + let ppx_exe = SC.PP.get_ppx_driver sctx pps in [ppx_exe] in List.concat @@ -1010,9 +998,15 @@ Add it to your jbuild file to remove this warning. SC.add_rule sctx (Build.symlink ~src:entry.src ~dst); Install.Entry.set_src entry dst) + let promote_install_file = + not ctx.implicit && + match ctx.kind with + | Default -> true + | Opam _ -> false + let install_file package_path package entries = let entries = - let files = SC.sources_and_targets_known_so_far sctx ~src_path:Path.root in + let files = SC.source_files sctx ~src_path:Path.root in String_set.fold files ~init:entries ~f:(fun fn acc -> if is_odig_doc_file fn then Install.Entry.make Doc (Path.relative ctx.build_dir fn) :: acc @@ -1024,15 +1018,9 @@ Add it to your jbuild file to remove this warning. Install.Entry.make Lib opam ~dst:"opam" :: entries in let entries = - (* Install a META file if the user wrote one or setup a rule to generate one, or if - we have at least another file to install in the lib/ directory *) let meta_fn = "META." ^ package in - if String_set.mem package packages_with_explicit_or_user_generated_meta || - List.exists entries ~f:(fun (e : Install.Entry.t) -> e.section = Lib) then - let meta = Path.append ctx.build_dir (Path.relative package_path meta_fn) in - Install.Entry.make Lib meta ~dst:"META" :: entries - else - entries + let meta = Path.append ctx.build_dir (Path.relative package_path meta_fn) in + Install.Entry.make Lib meta ~dst:"META" :: entries in let fn = Path.relative (Path.append ctx.build_dir package_path) @@ -1040,6 +1028,8 @@ Add it to your jbuild file to remove this warning. in let entries = local_install_rules entries ~package in SC.add_rule sctx + ?mode:(Option.some_if promote_install_file + Rule.Mode.Promote_but_delete_on_clean) (Build.path_set (Install.files entries) >>^ (fun () -> let entries = @@ -1054,7 +1044,7 @@ Add it to your jbuild file to remove this warning. >>> Build.write_file_dyn fn) - let () = + let init_install () = let entries_per_package = List.concat_map (SC.stanzas_to_consider_for_install sctx) ~f:(fun (dir, stanza) -> @@ -1072,36 +1062,54 @@ Add it to your jbuild file to remove this warning. let stanzas = String_map.find_default pkg.name entries_per_package ~default:[] in install_file pkg.path pkg.name stanzas) - let () = - let copy_to_src = - not ctx.implicit && - match ctx.kind with - | Default -> true - | Opam _ -> false - in + let init_install_files () = if not ctx.implicit then String_map.iter (SC.packages sctx) ~f:(fun ~key:pkg ~data:{ Package.path = src_path; _ } -> - let install_fn = Utils.install_file ~package:pkg ~findlib_toolchain:ctx.findlib_toolchain in + let install_fn = + Utils.install_file ~package:pkg ~findlib_toolchain:ctx.findlib_toolchain + in - let ctx_path = Path.append ctx.build_dir src_path in - let ctx_install_alias = Alias.install ~dir:ctx_path in - let ctx_install_file = Path.relative ctx_path install_fn in - Alias.add_deps (SC.aliases sctx) ctx_install_alias [ctx_install_file]; + let path = Path.append ctx.build_dir src_path in + let install_alias = Alias.install ~dir:path in + let install_file = Path.relative path install_fn in + SC.add_alias_deps sctx install_alias [install_file]) - if copy_to_src then begin - let src_install_alias = Alias.install ~dir:src_path in - let src_install_file = Path.relative src_path install_fn in - SC.add_rule sctx (Build.copy ~src:ctx_install_file ~dst:src_install_file); - Alias.add_deps (SC.aliases sctx) src_install_alias [src_install_file] - end) + let init () = + init_meta (); + init_install (); + init_install_files () + + let gen_rules ~dir components : Build_system.extra_sub_directories_to_keep = + (match components with + | ".js" :: rest -> Js_of_ocaml_rules.setup_separate_compilation_rules sctx rest; + | "_doc" :: rest -> Odoc.gen_rules sctx rest ~dir + | ".ppx" :: rest -> SC.PP.gen_rules sctx rest + | _ -> + match Path.Map.find dir stanzas_per_dir with + | Some x -> gen_rules x + | None -> + if components <> [] && + Option.is_none + (File_tree.find_dir (SC.file_tree sctx) + (Path.drop_build_context_exn dir)) then + SC.load_dir sctx ~dir:(Path.parent dir)); + match components with + | [] -> These (String_set.of_list [".js"; "_doc"; ".ppx"]) + | [(".js"|"_doc"|".ppx")] -> All + | _ -> These String_set.empty end -let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) - ?only_packages ?(unlink_aliases=[]) conf = +module type Gen = sig + val gen_rules : dir:Path.t -> string list -> Build_system.extra_sub_directories_to_keep + val init : unit -> unit +end + +let gen ~contexts ~build_system + ?(filter_out_optional_stanzas_with_missing_deps=true) + ?only_packages conf = let open Future in let { Jbuild_load. file_tree; jbuilds; packages; scopes } = conf in - let aliases = Alias.Store.create () in let packages = match only_packages with | None -> packages @@ -1109,55 +1117,47 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) String_map.filter packages ~f:(fun _ { Package.name; _ } -> String_set.mem name pkgs) in - let sctxs : (string, (Super_context.t * _)) Hashtbl.t = Hashtbl.create 4 in - let rec make_sctx (context : Context.t) : (_ * _) Future.t = - match Hashtbl.find sctxs context.name with - | Some r -> Future.return r - | None -> - let host = - match context.for_host with - | None -> Future.return None - | Some h -> make_sctx h >>| (fun (sctx, _) -> Some sctx) - in - let stanzas = - Jbuild_load.Jbuilds.eval ~context jbuilds >>| fun stanzas -> - match only_packages with - | None -> stanzas - | Some pkgs -> - List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) -> - (dir, - pkgs_ctx, - List.filter stanzas ~f:(fun stanza -> - match (stanza : Stanza.t) with - | Library { public = Some { package; _ }; _ } - | Alias { package = Some package ; _ } - | Install { package; _ } -> - String_set.mem package.name pkgs - | _ -> true))) - in - Future.both host stanzas >>| fun (host, stanzas) -> - let sctx = - Super_context.create - ?host - ~context - ~aliases - ~scopes - ~file_tree - ~packages - ~filter_out_optional_stanzas_with_missing_deps - ~stanzas - in - let module M = Gen(struct let sctx = sctx end) in - Hashtbl.add sctxs ~key:context.name ~data:(sctx, stanzas); - (sctx, stanzas) in - List.map ~f:make_sctx contexts - |> Future.all - >>| fun l -> - let rules, context_names_and_stanzas = - List.map l ~f:(fun (sctx, stanzas) -> - (Super_context.rules sctx, ((Super_context.context sctx).name, stanzas))) - |> List.split + let sctxs = Hashtbl.create 4 in + let make_sctx (context : Context.t) : _ Future.t = + let host = + Option.map context.for_host ~f:(fun h -> + Option.value_exn (Hashtbl.find sctxs h.name)) + in + let stanzas = + Jbuild_load.Jbuilds.eval ~context jbuilds >>| fun stanzas -> + match only_packages with + | None -> stanzas + | Some pkgs -> + List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) -> + (dir, + pkgs_ctx, + List.filter stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Library { public = Some { package; _ }; _ } + | Alias { package = Some package ; _ } + | Install { package; _ } -> + String_set.mem package.name pkgs + | _ -> true))) + in + stanzas >>| fun stanzas -> + let sctx = + Super_context.create + ?host + ~build_system + ~context + ~scopes + ~file_tree + ~packages + ~filter_out_optional_stanzas_with_missing_deps + ~stanzas + in + let module M = Gen(struct let sctx = sctx end) in + Hashtbl.add sctxs ~key:context.name ~data:sctx; + (context.name, ((module M : Gen), stanzas)) in - Alias.Store.unlink aliases unlink_aliases; - (Alias.rules aliases @ List.concat rules, - String_map.of_alist_exn context_names_and_stanzas) + Future.all (List.map ~f:make_sctx contexts) >>| fun l -> + let map = String_map.of_alist_exn l in + Build_system.set_rule_generators build_system + (String_map.map map ~f:(fun ((module M : Gen), _) -> M.gen_rules)); + String_map.iter map ~f:(fun ~key:_ ~data:((module M : Gen), _) -> M.init ()); + String_map.map map ~f:snd diff --git a/src/gen_rules.mli b/src/gen_rules.mli index 5a8fd414..f1f09c86 100644 --- a/src/gen_rules.mli +++ b/src/gen_rules.mli @@ -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 diff --git a/src/import.ml b/src/import.ml index 824034e0..23f52a74 100644 --- a/src/import.ml +++ b/src/import.ml @@ -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" diff --git a/src/io.ml b/src/io.ml index 1e0fdf09..ecdfe590 100644 --- a/src/io.ml +++ b/src/io.ml @@ -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) diff --git a/src/io.mli b/src/io.mli index 86ecc556..2e2c298c 100644 --- a/src/io.mli +++ b/src/io.mli @@ -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 diff --git a/src/jbuild.ml b/src/jbuild.ml index ca51b012..9fdbe577 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -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 }] diff --git a/src/jbuild.mli b/src/jbuild.mli index fca55afc..f9d36d8e 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -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 } diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index 245a091a..f84946a0 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -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 diff --git a/src/js_of_ocaml_rules.mli b/src/js_of_ocaml_rules.mli index fb13f908..98387b3e 100644 --- a/src/js_of_ocaml_rules.mli +++ b/src/js_of_ocaml_rules.mli @@ -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 diff --git a/src/main.ml b/src/main.ml index 7442ee39..53f6ad06 100644 --- a/src/main.ml +++ b/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 () diff --git a/src/main.mli b/src/main.mli index 13476a18..5e6c9c7c 100644 --- a/src/main.mli +++ b/src/main.mli @@ -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 diff --git a/src/merlin.ml b/src/merlin.ml index b25eb1e1..e20246fd 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -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 ) | _ -> () diff --git a/src/odoc.ml b/src/odoc.ml index 42756eb0..cdde58c0 100644 --- a/src/odoc.ml +++ b/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 diff --git a/src/odoc.mli b/src/odoc.mli index cbd8082e..31c9226c 100644 --- a/src/odoc.mli +++ b/src/odoc.mli @@ -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 diff --git a/src/path.ml b/src/path.ml index d8e2d68c..301adaf1 100644 --- a/src/path.ml +++ b/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 diff --git a/src/path.mli b/src/path.mli index 5a5020b0..52aab693 100644 --- a/src/path.mli +++ b/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 diff --git a/src/super_context.ml b/src/super_context.ml index 3d149813..ace3b4bc 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -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 diff --git a/src/super_context.mli b/src/super_context.mli index 4466bcc4..cb4f20cf 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -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 diff --git a/src/utils.ml b/src/utils.ml index f575b59c..5bad2601 100644 --- a/src/utils.ml +++ b/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 = diff --git a/src/utils.mli b/src/utils.mli index 1f077bd7..48fbdc21 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -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 diff --git a/test/blackbox-tests/test-cases/aliases/run.t b/test/blackbox-tests/test-cases/aliases/run.t index d684364b..707d8ced 100644 --- a/test/blackbox-tests/test-cases/aliases/run.t +++ b/test/blackbox-tests/test-cases/aliases/run.t @@ -12,11 +12,11 @@ running in src/foo/baz running in src $ $JBUILDER build -j1 --root . @plop - File "", 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 "", line 1, characters 0-0: + From the command line: Error: Don't know about directory truc! [1] diff --git a/test/blackbox-tests/test-cases/meta-gen/jbuild b/test/blackbox-tests/test-cases/meta-gen/jbuild index 1fca8023..3284c76f 100644 --- a/test/blackbox-tests/test-cases/meta-gen/jbuild +++ b/test/blackbox-tests/test-cases/meta-gen/jbuild @@ -23,5 +23,4 @@ (alias ((name runtest) - (deps (META.foobar)) - (action (echo "${read:META.foobar}")))) \ No newline at end of file + (action (echo "${read:META.foobar}"))))