diff --git a/CHANGES.md b/CHANGES.md index cb267527..30bc0fc7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,16 @@ +next +---- + +- Change the semantic of aliases: there are no longer aliases that are + recursive such as `install` or `runtest`. All aliases are + non-recursive. However, when requesting an alias from the command + line, this request the construction of the alias in the specified + directory and all its children recursively. This allows users to get + the same behavior as previous recursive aliases for their own + aliases, such as `example`. Inside jbuild files, one can use `(deps + (... (alias_rec xxx) ...))` to get the same behavior as on the + command line. + 1.0+beta14 (11/10/2017) ----------------------- diff --git a/bin/main.ml b/bin/main.ml index 4c94ed57..a5ce27d7 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -70,8 +70,23 @@ module Main = struct ?filter_out_optional_stanzas_with_missing_deps () end +type target = + | File of Path.t + | Alias_rec of Alias.t + +let request_of_targets (setup : Main.setup) targets = + let open Build.O 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) + let do_build (setup : Main.setup) targets = - Build_system.do_build_exn setup.build_system targets + Build_system.do_build_exn setup.build_system + ~request:(request_of_targets setup targets) let find_root () = let cwd = Sys.getcwd () in @@ -338,10 +353,6 @@ let resolve_package_install setup pkg = | Error () -> die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages)) -type target = - | File of Path.t - | Alias of Path.t * Alias.t - let target_hint (setup : Main.setup) path = assert (Path.is_local path); let sub_dir = Path.parent path in @@ -379,9 +390,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = if Path.is_root path then die "@@ on the command line must be followed by a valid alias name" else - let dir = Path.parent path in - let name = Path.basename path in - [Alias (path, Alias.make ~dir name)] + [Alias_rec (Alias.of_path path)] else let path = Path.relative Path.root (prefix_target common s) in let can't_build path = @@ -420,13 +429,13 @@ 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 (path, _) -> - Log.info log @@ "- alias " ^ (Path.to_string path)); + | Alias_rec alias -> + let path = Alias.fully_qualified_name alias in + Log.info log @@ "- recursive alias " ^ + (Path.to_string_maybe_quoted path)); flush stdout; end; - List.map targets ~f:(function - | File path -> path - | Alias (_, alias) -> Alias.file alias) + targets let build_targets = let doc = "Build the given targets, or all installable targets if none are given." in @@ -471,7 +480,7 @@ let runtest = let targets = List.map dirs ~f:(fun dir -> let dir = Path.(relative root) (prefix_target common dir) in - Alias.file (Alias.runtest ~dir)) + Alias_rec (Alias.runtest ~dir)) in do_build setup targets) in ( Term.(const go @@ -522,9 +531,10 @@ let external_lib_deps = (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false >>= fun setup -> let targets = resolve_targets ~log common setup targets in + let request = request_of_targets setup targets in let failure = String_map.fold ~init:false - (Build_system.all_lib_deps_by_context setup.build_system targets) + (Build_system.all_lib_deps_by_context setup.build_system ~request) ~f:(fun ~key:context_name ~data:lib_deps acc -> let internals = Jbuild.Stanzas.lib_names @@ -623,12 +633,12 @@ let rules = Future.Scheduler.go ~log (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false >>= fun setup -> - let targets = + let request = match targets with - | [] -> Build_system.all_targets setup.build_system - | _ -> resolve_targets ~log common setup targets + | [] -> Build.paths (Build_system.all_targets setup.build_system) + | _ -> resolve_targets ~log common setup targets |> request_of_targets setup in - Build_system.build_rules setup.build_system targets ~recursive >>= fun rules -> + Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules -> let print oc = let ppf = Format.formatter_of_out_channel oc in Sexp.prepare_formatter ppf; @@ -918,10 +928,10 @@ let utop = let target = match resolve_targets ~log common setup [utop_target] with | [] -> die "no libraries defined in %s" dir - | [target] -> target - | _::_::_ -> assert false + | [File target] -> target + | [Alias_rec _] | _::_::_ -> assert false in - do_build setup [target] >>| fun () -> + 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; diff --git a/doc/jbuild.rst b/doc/jbuild.rst index c9067f66..78e8bb63 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -843,6 +843,10 @@ syntax: - ``(file )`` or simply ````: depend on this file - ``(alias )``: depend on the construction of this alias, for instance: ``(alias src/runtest)`` +- ``(alias_rec )``: depend on the construction of this + alias recursively in all children directories wherever it is + defined. For instance: ``(alias_rec src/runtest)`` might depend on + ``(alias src/runtest)``, ``(alias src/foo/bar/runtest)``, ... - ``(glob_files )``: depend on all files matched by ````, see the :ref:`glob ` for details - ``(files_recursively_in )``: depend on all files in the subtree with root diff --git a/doc/terminology.rst b/doc/terminology.rst index 0e724950..cd373b48 100644 --- a/doc/terminology.rst +++ b/doc/terminology.rst @@ -43,11 +43,12 @@ Terminology - **build context root**: the root of a build context named ``foo`` is ``/_build/`` -- **alias**: an alias is a build target that doesn't produce any file - and has configurable dependencies. Alias are per-directory and some - are recursive; asking an alias to be built in a given directory will - trigger the construction of the alias in all children directories - recursively. The most interesting ones are: +- **alias**: an alias is a build target that doesn't produce any file + and has configurable dependencies. Aliases are + per-directory. However, on the command line, asking for an alias to + be built in a given directory will trigger the construction of the + alias in all children directories recursively. Jbuilder defines the + following standard aliases: - ``runtest`` which runs user defined tests - ``install`` which depends on everything that should be installed diff --git a/doc/usage.rst b/doc/usage.rst index 45f2397f..4c81b382 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -125,8 +125,9 @@ Aliases ------- Targets starting with a ``@`` are interpreted as aliases. For instance -``@src/runtest`` means the alias ``src/runtest``. If you want to refer -to a target starting with a ``@``, simply write: ``./@foo``. +``@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``. Note that an alias not pointing to the ``_build`` directory always depends on all the corresponding aliases in build contexts. diff --git a/src/alias.ml b/src/alias.ml index 9456778f..c391aedd 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -3,12 +3,14 @@ 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 = @@ -16,6 +18,10 @@ type 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' @@ -32,12 +38,43 @@ let of_path path = 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" -> true + | _ -> false + +let dep_rec ~loc ~file_tree t = + let path = Path.parent (Fq_name.path t.name) |> Path.drop_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 = @@ -77,20 +114,29 @@ let runtest = make "runtest" let install = make "install" let doc = make "doc" -let recursive_aliases = - [ default - ; runtest - ; install - ; doc - ] - 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 end @@ -104,22 +150,7 @@ let add_deps store t deps = } | Some e -> e.deps <- Path.Set.union deps e.deps -type tree = Node of Path.t * tree list - -let rec setup_rec_alias store ~make_alias ~prefix ~tree:(Node (dir, children)) = - let alias = make_alias ~dir:(Path.append prefix dir) in - add_deps store alias (List.map children ~f:(fun child -> - setup_rec_alias store ~make_alias ~prefix ~tree:child)); - alias.file - -let setup_rec_aliases store ~prefix ~tree = - List.iter recursive_aliases ~f:(fun make_alias -> - ignore (setup_rec_alias store ~make_alias ~prefix ~tree : Path.t)) - -let rules store ~prefixes ~tree = - List.iter prefixes ~f:(fun prefix -> - setup_rec_aliases store ~prefix ~tree); - +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 diff --git a/src/alias.mli b/src/alias.mli index c976e35b..502432df 100644 --- a/src/alias.mli +++ b/src/alias.mli @@ -1,7 +1,13 @@ +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: {[ @@ -11,6 +17,8 @@ val make : string -> dir:Path.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 @@ -18,6 +26,10 @@ val doc : 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 @@ -43,15 +55,12 @@ val name_of_file : Path.t -> string option module Store : sig type t + + val pp : t Fmt.t + val create : unit -> t end val add_deps : Store.t -> t -> Path.t list -> unit -type tree = Node of Path.t * tree list - -val rules - : Store.t - -> prefixes:Path.t list - -> tree:tree - -> Build_interpret.Rule.t list +val rules : Store.t -> Build_interpret.Rule.t list diff --git a/src/build_system.ml b/src/build_system.ml index 5ec9745e..876461e4 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -125,6 +125,7 @@ type t = [(deps (filename + contents), targets (filename only), action)] *) trace : (Path.t, Digest.t) Hashtbl.t ; mutable local_mkdirs : Path.Local.Set.t + ; all_targets_by_dir : Pset.t Pmap.t Lazy.t } let all_targets t = Hashtbl.fold t.files ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) @@ -304,6 +305,9 @@ module Build_exec = struct let dyn_deps = ref Pset.empty in let action = exec dyn_deps (Build.repr t) x in (action, !dyn_deps) + + let exec_nop bs t x = + 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 @@ -603,14 +607,14 @@ let dump_trace t = Trace.dump t.trace let create ~contexts ~file_tree ~rules = let all_source_files = - File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc -> - let path = File_tree.Dir.path dir in - Cont - (Pset.union acc - (File_tree.Dir.files dir - |> String_set.elements - |> List.map ~f:(Path.relative path) - |> Pset.of_list))) + 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)) in let all_copy_targets = List.fold_left contexts ~init:Pset.empty ~f:(fun acc (ctx : Context.t) -> @@ -638,6 +642,7 @@ let create ~contexts ~file_tree ~rules = ; 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 @@ -717,13 +722,34 @@ let remove_old_artifacts t = walk (Config.local_install_dir ~context:ctx.name); ) -let do_build_exn t targets = - remove_old_artifacts t; - all_unit (List.map targets ~f:(fun fn -> wait_for_file t fn ~targeting:fn)) +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 + in -let do_build t targets = + let process_targets ts = + Future.all_unit (List.map (Pset.elements ts) ~f:process_target) + in + + Future.both + (process_targets static_deps) + (Future.all_unit (List.map (Pset.elements rule_deps) ~f:(fun fn -> + wait_for_file t fn ~targeting:fn)) + >>= fun () -> + let dyn_deps = Build_exec.exec_nop t request () in + process_targets (Pset.diff dyn_deps static_deps)) + >>| 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) + +let do_build t ~request = try - Ok (do_build_exn t targets) + Ok (do_build_exn t ~request) with Build_error.E e -> Error e @@ -760,7 +786,16 @@ let rules_for_targets t targets = Path.to_string (Pset.choose rule.Internal_rule.targets)) |> String.concat ~sep:"\n-> ") -let all_lib_deps t targets = +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 + in + Pset.elements (Pset.union rule_deps action_deps) + +let all_lib_deps t ~request = + let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:Pmap.empty ~f:(fun acc rule -> let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in @@ -771,7 +806,8 @@ let all_lib_deps t targets = | None, Some b -> Some b | Some a, Some b -> Some (Build.merge_lib_deps a b))) -let all_lib_deps_by_context t targets = +let all_lib_deps_by_context t ~request = + let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc rule -> let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in Path.Map.fold lib_deps ~init:acc ~f:(fun ~key:path ~data:lib_deps acc -> @@ -817,7 +853,7 @@ module Rule_closure = rules_for_files graph (Pset.elements t.deps) end) -let build_rules t ?(recursive=false) targets = +let build_rules ?(recursive=false) t ~request = let rules_seen = ref Id_set.empty in let rules = ref [] in let rec loop fn = @@ -863,7 +899,10 @@ let build_rules t ?(recursive=false) targets = return () end in - Future.all_unit (List.map targets ~f:loop) + let targets = ref Pset.empty in + eval_request t ~request ~process_target:(fun fn -> + targets := Pset.add fn !targets; + loop fn) >>= fun () -> Future.all !rules >>| fun rules -> @@ -872,7 +911,10 @@ let build_rules t ?(recursive=false) targets = Pset.fold r.targets ~init:acc ~f:(fun fn acc -> Pmap.add acc ~key:fn ~data:r)) in - match Rule_closure.top_closure rules (rules_for_files rules targets) with + match + Rule_closure.top_closure rules + (rules_for_files rules (Pset.elements !targets)) + with | Ok l -> l | Error cycle -> die "dependency cycle detected:\n %s" diff --git a/src/build_system.mli b/src/build_system.mli index 0099770c..1eac9030 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -23,16 +23,28 @@ module Build_error : sig end (** Do the actual build *) -val do_build : t -> Path.t list -> (unit Future.t, Build_error.t) result -val do_build_exn : t -> Path.t list -> unit Future.t +val do_build + : t + -> request:(unit, unit) Build.t + -> (unit Future.t, Build_error.t) result +val do_build_exn + : t + -> request:(unit, unit) Build.t + -> unit Future.t -(** Return all the library dependencies (as written by the user) needed to build these - targets *) -val all_lib_deps : t -> Path.t list -> Build.lib_deps Path.Map.t +(** Return all the library dependencies (as written by the user) + needed to build this request *) +val all_lib_deps + : t + -> request:(unit, unit) Build.t + -> Build.lib_deps Path.Map.t -(** Return all the library dependencies required to build these targets, by context - name *) -val all_lib_deps_by_context : t -> Path.t list -> Build.lib_deps String_map.t +(** Return all the library dependencies required to build this + request, by context name *) +val all_lib_deps_by_context + : t + -> request:(unit, unit) Build.t + -> Build.lib_deps String_map.t (** List of all buildable targets *) val all_targets : t -> Path.t list @@ -58,9 +70,9 @@ end [recursive] is [true], return all the rules needed to build the given targets and their transitive dependencies. *) val build_rules - : t - -> ?recursive:bool (* default false *) - -> Path.t list + : ?recursive:bool (* default false *) + -> t + -> request:(unit, unit) Build.t -> Rule.t list Future.t val all_targets_ever_built diff --git a/src/file_tree.ml b/src/file_tree.ml index 29b2c544..5649d2c7 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -1,31 +1,25 @@ open! Import -type 'a fold_callback_result = - | Cont of 'a - | Dont_recurse_in of String_set.t * 'a - module Dir = struct type t = { path : Path.t ; files : String_set.t ; sub_dirs : t String_map.t + ; ignored : bool } let path t = t.path let files t = t.files let sub_dirs t = t.sub_dirs + let ignored t = t.ignored - let rec fold t ~init ~f = - match f t init with - | Cont init -> - String_map.fold t.sub_dirs ~init ~f:(fun ~key:_ ~data:t acc -> - fold t ~init:acc ~f) - | Dont_recurse_in (forbidden, init) -> - String_map.fold t.sub_dirs ~init ~f:(fun ~key:sub_dir ~data:t acc -> - if String_set.mem sub_dir forbidden then - acc - else - fold t ~init:acc ~f) + let rec fold t ~traverse_ignored_dirs ~init:acc ~f = + if not traverse_ignored_dirs && t.ignored then + acc + else + let acc = f t acc in + String_map.fold t.sub_dirs ~init:acc ~f:(fun ~key:_ ~data:t acc -> + fold t ~traverse_ignored_dirs ~init:acc ~f) end type t = @@ -40,38 +34,59 @@ let ignore_file fn ~is_directory = (is_directory && (fn.[0] = '.' || fn.[0] = '_')) || (fn.[0] = '.' && fn.[1] = '#') -let load path = - let rec walk path : Dir.t = +let load ?(extra_ignored_subtrees=Path.Set.empty) path = + let rec walk path ~ignored : Dir.t = let files, sub_dirs = Path.readdir path |> List.filter_map ~f:(fun fn -> let path = Path.relative path fn in - let is_directory = Path.exists path && Path.is_directory path in + let is_directory = + try Path.is_directory path with _ -> false + in if ignore_file fn ~is_directory then None + else if is_directory then + Some (Inr (fn, path)) else - Some (fn, path, is_directory)) - |> List.partition_map ~f:(fun (fn, path, is_directory) -> - if is_directory then - Inr (fn, walk path) - else - Inl fn) + Some (Inl fn)) + |> List.partition_map ~f:(fun x -> x) + in + let files = String_set.of_list files in + let ignored_sub_dirs = + if not ignored && String_set.mem "jbuild-ignore" files then + String_set.of_list + (Io.lines_of_file (Path.to_string (Path.relative path "jbuild-ignore"))) + else + String_set.empty + in + let sub_dirs = + List.map sub_dirs ~f:(fun (fn, path) -> + let ignored = + ignored + || String_set.mem fn ignored_sub_dirs + || Path.Set.mem path extra_ignored_subtrees + in + (fn, walk path ~ignored)) + |> String_map.of_alist_exn in { path - ; files = String_set.of_list files - ; sub_dirs = String_map.of_alist_exn sub_dirs + ; files + ; sub_dirs + ; ignored } in - let root = walk path in + let root = walk path ~ignored:false in let dirs = - Dir.fold root ~init:Path.Map.empty ~f:(fun dir acc -> - Cont (Path.Map.add acc ~key:dir.path ~data:dir)) + Dir.fold root ~init:Path.Map.empty ~traverse_ignored_dirs:true + ~f:(fun dir acc -> + Path.Map.add acc ~key:dir.path ~data:dir) in { root ; dirs } -let fold t ~init ~f = Dir.fold t.root ~init ~f +let fold t ~traverse_ignored_dirs ~init ~f = + Dir.fold t.root ~traverse_ignored_dirs ~init ~f let find_dir t path = Path.Map.find path t.dirs @@ -89,8 +104,8 @@ let files_recursively_in t ?(prefix_with=Path.root) path = match find_dir t path with | None -> Path.Set.empty | Some dir -> - Dir.fold dir ~init:Path.Set.empty ~f:(fun dir acc -> - let path = Path.append prefix_with (Dir.path dir) in - Cont - (String_set.fold (Dir.files dir) ~init:acc ~f:(fun fn acc -> - Path.Set.add (Path.relative path fn) acc))) + Dir.fold dir ~init:Path.Set.empty ~traverse_ignored_dirs:true + ~f:(fun dir acc -> + let path = Path.append prefix_with (Dir.path dir) in + String_set.fold (Dir.files dir) ~init:acc ~f:(fun fn acc -> + Path.Set.add (Path.relative path fn) acc)) diff --git a/src/file_tree.mli b/src/file_tree.mli index ad41e6ea..44a339a3 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -1,23 +1,34 @@ open! Import - module Dir : sig type t val path : t -> Path.t val files : t -> String_set.t val sub_dirs : t -> t String_map.t + + (** Whether this directory is ignored by a [jbuild-ignore] file in + one of its ancestor directories. *) + val ignored : t -> bool + + val fold + : t + -> traverse_ignored_dirs:bool + -> init:'a + -> f:(t -> 'a -> 'a) + -> 'a end type t -val load : Path.t -> t +val load : ?extra_ignored_subtrees:Path.Set.t -> Path.t -> t -type 'a fold_callback_result = - | Cont of 'a - | Dont_recurse_in of String_set.t * 'a - -val fold : t -> init:'a -> f:(Dir.t -> 'a -> 'a fold_callback_result) -> 'a +val fold + : t + -> traverse_ignored_dirs:bool + -> init:'a + -> f:(Dir.t -> 'a -> 'a) + -> 'a val root : t -> Dir.t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index b0dbd779..2346728f 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1104,7 +1104,7 @@ end let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) ?only_packages conf = let open Future in - let { Jbuild_load. file_tree; tree; jbuilds; packages } = conf in + let { Jbuild_load. file_tree; jbuilds; packages } = conf in let aliases = Alias.Store.create () in let dirs_with_dot_opam_files = String_map.fold packages ~init:Path.Set.empty @@ -1150,7 +1150,5 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) |> Future.all >>| fun l -> let rules, context_names_and_stanzas = List.split l in - (Alias.rules aliases - ~prefixes:(Path.root :: List.map contexts ~f:(fun c -> c.Context.build_dir)) ~tree - @ List.concat rules, + (Alias.rules aliases @ List.concat rules, String_map.of_alist_exn context_names_and_stanzas) diff --git a/src/import.ml b/src/import.ml index 279ec789..4c3f84b9 100644 --- a/src/import.ml +++ b/src/import.ml @@ -504,3 +504,7 @@ let open_out_gen = `Use_Io module No_io = struct module Io = struct end end + +module Fmt = struct + type 'a t = Format.formatter -> 'a -> unit +end diff --git a/src/jbuild.ml b/src/jbuild.ml index a2ca8ae4..9c186cc2 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -200,6 +200,7 @@ module Dep_conf = struct type t = | File of String_with_vars.t | Alias of String_with_vars.t + | Alias_rec of String_with_vars.t | Glob_files of String_with_vars.t | Files_recursively_in of String_with_vars.t @@ -211,6 +212,7 @@ module Dep_conf = struct sum [ cstr "file" (fun x -> File x) ; cstr "alias" (fun x -> Alias x) + ; cstr "alias_rec" (fun x -> Alias_rec x) ; cstr "glob_files" (fun x -> Glob_files x) ; cstr "files_recursively_in" (fun x -> Files_recursively_in x) ] @@ -226,6 +228,8 @@ module Dep_conf = struct List [Atom "file" ; String_with_vars.sexp_of_t t] | Alias t -> List [Atom "alias" ; String_with_vars.sexp_of_t t] + | Alias_rec t -> + List [Atom "alias_rec" ; String_with_vars.sexp_of_t t] | Glob_files t -> List [Atom "glob_files" ; String_with_vars.sexp_of_t t] | Files_recursively_in t -> diff --git a/src/jbuild.mli b/src/jbuild.mli index 5fe849c4..38ba0c35 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -93,6 +93,7 @@ module Dep_conf : sig type t = | File of String_with_vars.t | Alias of String_with_vars.t + | Alias_rec of String_with_vars.t | Glob_files of String_with_vars.t | Files_recursively_in of String_with_vars.t diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 2d3100a1..c0622e7a 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -151,7 +151,6 @@ end type conf = { file_tree : File_tree.t - ; tree : Alias.tree ; jbuilds : Jbuilds.t ; packages : Package.t String_map.t } @@ -164,41 +163,27 @@ let load ~dir ~scope = | Ocaml_script -> Script { dir; scope } -let load ?(extra_ignored_subtrees=Path.Set.empty) () = - let ftree = File_tree.load Path.root in - let packages, ignored_subtrees = - File_tree.fold ftree ~init:([], extra_ignored_subtrees) ~f:(fun dir (pkgs, ignored) -> +let load ?extra_ignored_subtrees () = + let ftree = File_tree.load Path.root ?extra_ignored_subtrees in + let packages = + File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs -> let path = File_tree.Dir.path dir in let files = File_tree.Dir.files dir in - let pkgs = - String_set.fold files ~init:pkgs ~f:(fun fn acc -> - match Filename.split_extension fn with - | (pkg, ".opam") when pkg <> "" -> - let version_from_opam_file = - let opam = Opam_file.load (Path.relative path fn |> Path.to_string) in - match Opam_file.get_field opam "version" with - | Some (String (_, s)) -> Some s - | _ -> None - in - (pkg, - { Package. name = pkg - ; path - ; version_from_opam_file - }) :: acc - | _ -> acc) - in - if String_set.mem "jbuild-ignore" files then - let ignore_set = - String_set.of_list - (Io.lines_of_file (Path.to_string (Path.relative path "jbuild-ignore"))) - in - Dont_recurse_in - (ignore_set, - (pkgs, - String_set.fold ignore_set ~init:ignored ~f:(fun fn acc -> - Path.Set.add (Path.relative path fn) acc))) - else - Cont (pkgs, ignored)) + String_set.fold files ~init:pkgs ~f:(fun fn acc -> + match Filename.split_extension fn with + | (pkg, ".opam") when pkg <> "" -> + let version_from_opam_file = + let opam = Opam_file.load (Path.relative path fn |> Path.to_string) in + match Opam_file.get_field opam "version" with + | Some (String (_, s)) -> Some s + | _ -> None + in + (pkg, + { Package. name = pkg + ; path + ; version_from_opam_file + }) :: acc + | _ -> acc)) in let packages = String_map.of_alist_multi packages @@ -219,32 +204,27 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) () = |> Path.Map.map ~f:Scope.make in let rec walk dir jbuilds scope = - let path = File_tree.Dir.path dir in - let files = File_tree.Dir.files dir in - let sub_dirs = File_tree.Dir.sub_dirs dir in - let scope = Path.Map.find_default path scopes ~default:scope in - let jbuilds = - if String_set.mem "jbuild" files then - let jbuild = load ~dir:path ~scope in - jbuild :: jbuilds - else - jbuilds - in - let children, jbuilds = - String_map.fold sub_dirs ~init:([], jbuilds) - ~f:(fun ~key:_ ~data:dir (children, jbuilds) -> - if Path.Set.mem (File_tree.Dir.path dir) ignored_subtrees then - (children, jbuilds) - else - let child, jbuilds = walk dir jbuilds scope in - (child :: children, jbuilds)) - in - (Alias.Node (path, children), jbuilds) + if File_tree.Dir.ignored dir then + jbuilds + else begin + let path = File_tree.Dir.path dir in + let files = File_tree.Dir.files dir in + let sub_dirs = File_tree.Dir.sub_dirs dir in + let scope = Path.Map.find_default path scopes ~default:scope in + let jbuilds = + if String_set.mem "jbuild" files then + let jbuild = load ~dir:path ~scope in + jbuild :: jbuilds + else + jbuilds + in + String_map.fold sub_dirs ~init:jbuilds + ~f:(fun ~key:_ ~data:dir jbuilds -> + walk dir jbuilds scope) + end in - let root = File_tree.root ftree in - let tree, jbuilds = walk root [] Scope.empty in + let jbuilds = walk (File_tree.root ftree) [] Scope.empty in { file_tree = ftree - ; tree ; jbuilds ; packages } diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index 2f8fb6ff..67998263 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -9,7 +9,6 @@ end type conf = { file_tree : File_tree.t - ; tree : Alias.tree ; jbuilds : Jbuilds.t ; packages : Package.t String_map.t } diff --git a/src/main.ml b/src/main.ml index 569a2b51..6329704c 100644 --- a/src/main.ml +++ b/src/main.ml @@ -6,6 +6,7 @@ type setup = ; stanzas : (Path.t * Jbuild.Scope.t * Jbuild.Stanzas.t) list String_map.t ; contexts : Context.t list ; packages : Package.t String_map.t + ; file_tree : File_tree.t } let package_install_file { packages; _ } pkg = @@ -54,6 +55,7 @@ let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps ; stanzas ; contexts ; packages = conf.packages + ; file_tree = conf.file_tree } let external_lib_deps ?log ~packages () = @@ -71,7 +73,8 @@ let external_lib_deps ?log ~packages () = | Some stanzas -> let internals = Jbuild.Stanzas.lib_names stanzas in Path.Map.map - (Build_system.all_lib_deps setup.build_system install_files) + (Build_system.all_lib_deps setup.build_system + ~request:(Build.paths install_files)) ~f:(String_map.filter ~f:(fun name _ -> not (String_set.mem name internals)))) @@ -211,7 +214,8 @@ let bootstrap () = ~extra_ignored_subtrees:ignored_during_bootstrap () >>= fun { build_system = bs; _ } -> - Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) + Build_system.do_build_exn bs + ~request:(Build.path (Path.(relative root) (pkg ^ ".install")))) in try main () diff --git a/src/main.mli b/src/main.mli index f7167eb8..d8c573ac 100644 --- a/src/main.mli +++ b/src/main.mli @@ -7,6 +7,7 @@ type setup = stanzas : (Path.t * Scope.t * Stanzas.t) list String_map.t ; contexts : Context.t list ; packages : Package.t String_map.t + ; file_tree : File_tree.t } (* Returns [Error ()] if [pkg] is unknown *) diff --git a/src/path.ml b/src/path.ml index 9aefa25b..996fd267 100644 --- a/src/path.ml +++ b/src/path.ml @@ -424,3 +424,5 @@ let rm_rf = let change_extension ~ext t = let t = try Filename.chop_extension t with Not_found -> t in t ^ ext + +let pp = Format.pp_print_string diff --git a/src/path.mli b/src/path.mli index 1fc5f699..31d781d2 100644 --- a/src/path.mli +++ b/src/path.mli @@ -111,3 +111,5 @@ val rm_rf : t -> unit (** Changes the extension of the filename (or adds an extension if there was none) *) val change_extension : ext:string -> t -> t + +val pp : t Fmt.t diff --git a/src/super_context.ml b/src/super_context.ml index 4e8ebe14..0c74d8ba 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -406,15 +406,21 @@ module Deps = struct open Build.O open Dep_conf + let make_alias t ~scope ~dir s = + Alias.of_path (Path.relative dir (expand_vars t ~scope ~dir s)) + let dep t ~scope ~dir = function | File s -> let path = Path.relative dir (expand_vars t ~scope ~dir s) in Build.path path - >>^ fun _ -> [path] + >>^ fun () -> [path] | Alias s -> - let path = Alias.file (Alias.make ~dir (expand_vars t ~scope ~dir s)) in - Build.path path - >>^ fun _ -> [] + Alias.dep (make_alias t ~scope ~dir s) + >>^ fun () -> [] + | Alias_rec s -> + Alias.dep_rec ~loc:(String_with_vars.loc s) ~file_tree:t.file_tree + (make_alias t ~scope ~dir s) + >>^ fun () -> [] | Glob_files s -> begin let path = Path.relative dir (expand_vars t ~scope ~dir s) in match Glob_lexer.parse_string (Path.basename path) with diff --git a/test/blackbox-tests/jbuild b/test/blackbox-tests/jbuild index 6317e0a8..7c5def1e 100644 --- a/test/blackbox-tests/jbuild +++ b/test/blackbox-tests/jbuild @@ -71,3 +71,10 @@ (action (chdir test-cases/copy_files (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t)))))) + +(alias + ((name runtest) + (deps ((files_recursively_in test-cases/aliases))) + (action + (chdir test-cases/aliases + (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t)))))) diff --git a/test/blackbox-tests/test-cases/aliases/jbuild b/test/blackbox-tests/test-cases/aliases/jbuild new file mode 100644 index 00000000..40466632 --- /dev/null +++ b/test/blackbox-tests/test-cases/aliases/jbuild @@ -0,0 +1,9 @@ +(jbuild_version 1) + +(alias + ((name just-in-src) + (deps ((alias src/x))))) + +(alias + ((name everywhere) + (deps ((alias_rec x))))) diff --git a/test/blackbox-tests/test-cases/aliases/run.t b/test/blackbox-tests/test-cases/aliases/run.t new file mode 100644 index 00000000..d684364b --- /dev/null +++ b/test/blackbox-tests/test-cases/aliases/run.t @@ -0,0 +1,22 @@ + $ $JBUILDER clean -j1 --root . + $ $JBUILDER build -j1 --root . @just-in-src + running in src + $ $JBUILDER clean -j1 --root . + $ $JBUILDER build -j1 --root . @everywhere + running in src/foo/bar + running in src/foo/baz + running in src + $ $JBUILDER clean -j1 --root . + $ $JBUILDER build -j1 --root . @x + running in src/foo/bar + 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. + [1] + $ $JBUILDER build -j1 --root . @truc/x + File "", line 1, characters 0-0: + Error: Don't know about directory truc! + [1] diff --git a/test/blackbox-tests/test-cases/aliases/src/foo/bar/jbuild b/test/blackbox-tests/test-cases/aliases/src/foo/bar/jbuild new file mode 100644 index 00000000..aafdaf1c --- /dev/null +++ b/test/blackbox-tests/test-cases/aliases/src/foo/bar/jbuild @@ -0,0 +1,5 @@ +(jbuild_version 1) + +(alias + ((name x) + (action (chdir ${ROOT} (echo "running in ${path-no-dep:.}\n"))))) diff --git a/test/blackbox-tests/test-cases/aliases/src/foo/baz/jbuild b/test/blackbox-tests/test-cases/aliases/src/foo/baz/jbuild new file mode 100644 index 00000000..aafdaf1c --- /dev/null +++ b/test/blackbox-tests/test-cases/aliases/src/foo/baz/jbuild @@ -0,0 +1,5 @@ +(jbuild_version 1) + +(alias + ((name x) + (action (chdir ${ROOT} (echo "running in ${path-no-dep:.}\n"))))) diff --git a/test/blackbox-tests/test-cases/aliases/src/jbuild b/test/blackbox-tests/test-cases/aliases/src/jbuild new file mode 100644 index 00000000..aafdaf1c --- /dev/null +++ b/test/blackbox-tests/test-cases/aliases/src/jbuild @@ -0,0 +1,5 @@ +(jbuild_version 1) + +(alias + ((name x) + (action (chdir ${ROOT} (echo "running in ${path-no-dep:.}\n"))))) diff --git a/test/blackbox-tests/test-cases/js_of_ocaml/run.t b/test/blackbox-tests/test-cases/js_of_ocaml/run.t index 05275e2d..bb357cb0 100644 --- a/test/blackbox-tests/test-cases/js_of_ocaml/run.t +++ b/test/blackbox-tests/test-cases/js_of_ocaml/run.t @@ -1,29 +1,29 @@ $ $JBUILDER build -j1 --root . --dev bin/technologic.bc.js @install lib/x.cma.js lib/x__Y.cmo.js bin/z.cmo.js - ocamlopt .ppx/js_of_ocaml-ppx/ppx.exe ocamlc lib/stubs.o + ocamlopt .ppx/js_of_ocaml-ppx/ppx.exe ocamlc lib/x__.{cmi,cmo,cmt} - ppx bin/technologic.pp.ml - ppx bin/z.pp.ml + ocamlmklib lib/dllx_stubs.so,lib/libx_stubs.a ppx lib/x.pp.ml ppx lib/y.pp.ml - ocamlmklib lib/dllx_stubs.so,lib/libx_stubs.a + ppx bin/technologic.pp.ml + ppx bin/z.pp.ml ocamlopt lib/x__.{cmx,o} - ocamldep bin/technologic.depends.ocamldep-output ocamldep lib/x.depends.ocamldep-output + ocamldep bin/technologic.depends.ocamldep-output + ocamlc lib/x__Y.{cmi,cmo,cmt} js_of_ocaml .js/js_of_ocaml/js_of_ocaml.cma.js js_of_ocaml .js/stdlib/stdlib.cma.js - ocamlc lib/x__Y.{cmi,cmo,cmt} js_of_ocaml lib/x__Y.cmo.js ocamlopt lib/x__Y.{cmx,o} ocamlc lib/x.{cmi,cmo,cmt} ocamlopt lib/x.{cmx,o} - ocamlc bin/z.{cmi,cmo,cmt} ocamlc lib/x.cma + ocamlc bin/z.{cmi,cmo,cmt} ocamlopt lib/x.{a,cmxa} - js_of_ocaml bin/z.cmo.js - ocamlc bin/technologic.{cmi,cmo,cmt} js_of_ocaml lib/x.cma.js js_of_ocaml bin/technologic.bc.runtime.js + js_of_ocaml bin/z.cmo.js + ocamlc bin/technologic.{cmi,cmo,cmt} ocamlopt lib/x.cmxs js_of_ocaml bin/technologic.cmo.js jsoo_link bin/technologic.bc.js @@ -34,17 +34,17 @@ fix it $ $JBUILDER build -j1 --root . bin/technologic.bc.js @install ocamlc lib/x__.{cmi,cmo,cmt} - ocamlc lib/x__Y.{cmi,cmo,cmt} ocamlopt lib/x__.{cmx,o} - ocamlc lib/x.{cmi,cmo,cmt} + ocamlc lib/x__Y.{cmi,cmo,cmt} ocamlopt lib/x__Y.{cmx,o} + ocamlc lib/x.{cmi,cmo,cmt} + ocamlopt lib/x.{cmx,o} ocamlc lib/x.cma ocamlc bin/z.{cmi,cmo,cmt} - ocamlopt lib/x.{cmx,o} - ocamlc bin/technologic.{cmi,cmo,cmt} ocamlopt lib/x.{a,cmxa} - ocamlc bin/technologic.bc + ocamlc bin/technologic.{cmi,cmo,cmt} ocamlopt lib/x.cmxs + ocamlc bin/technologic.bc js_of_ocaml bin/technologic.bc.js $ $NODE ./_build/default/bin/technologic.bc.js buy it