Improve alias management

bin/main.ml

@@ -129,11 +129,6 @@ type target =
   | File  of Path.t
   | Alias of Path.t * Alias.t
 
-let aliases_in_source_tree =
-  String_set.of_list
-    [ "install"
-    ]
-
 let resolve_targets (setup : Main.setup) user_targets =
   match user_targets with
   | [] -> []
@@ -146,15 +141,8 @@ let resolve_targets (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 name = Path.basename path in
-            let path =
-              if Path.is_in_build_dir path ||
-                 String_set.mem name aliases_in_source_tree then
-                path
-              else
-                Path.append setup.context.build_dir path
-            in
             let dir = Path.parent path in
+            let name = Path.basename path in
             Alias (path, Alias.make ~dir name)
         else
           File (

doc/manual.org

@@ -130,12 +130,10 @@ Jbuilder doesn't read =<package>.opam= files, however when a
 =<package>.opam= is present, Jbuilder will knows that the package
 named =<package>= exists. It will know how to construct a
 =<package>.install= file in the same directory, to handle installation
-via [[https://opam.ocaml.org/][opam]]. In addition, Jbuilder will also know how to build
+via [[https://opam.ocaml.org/][opam]]. Jbuilder also defines the recursive =install= alias, which depends
-=<package>.install= at the root of the workspace, for
+on all the buildable =<package>.install= files in the workspace. So
-convenience. Jbuilder also defines the =install= alias, which depends
+for instance to build everything that is installable in a workspace,
-on all the buildable =<package>.install= at the root of the
+run at the root:
-workspace. So for instance to build everything that is installable in
-a workspace, run:
 
 #+begin_src
 $ jbuilder build @install

src/alias.ml

@@ -1,39 +1,66 @@
 open! Import
 
-type t = Path.t
+module Name : sig
+  type t
+  val make : Path.t -> t
+  val path : t -> Path.t
+end = struct
+  type t = Path.t
+  let make t = t
+  let path t = t
+end
+
+type t =
+  { name : Name.t
+  ; file : Path.t
+  }
 
 let aliases_path = Path.(relative root) "_build/.aliases"
 
-let make name ~dir =
+let of_path path =
-  if not (Path.is_local dir) then
+  if not (Path.is_local path) then
     die "Aliases are only supported for local paths!\n\
-         Tried to reference alias %S in %s"
+         Tried to reference alias %S"
-      name (Path.to_string dir);
+      (Path.to_string path);
-  Path.append aliases_path (Path.relative dir name)
+  { name = Name.make path
+  ; file = Path.append aliases_path path
+  }
 
-let dep = Build.path
+let make name ~dir = of_path (Path.relative dir name)
 
-let file t = t
+let dep t = Build.path t.file
+
+let file t = t.file
 
 let default = make "DEFAULT"
 let runtest = make "runtest"
+let install = make "install"
 
 let recursive_aliases =
   [ default
   ; runtest
+  ; install
   ]
 
 module Store = struct
-  type nonrec t = (t, Path.Set.t ref) Hashtbl.t
+  type entry =
+    { alias : t
+    ; mutable deps : Path.Set.t
+    }
+  type t = (Name.t, entry) Hashtbl.t
 
   let create () = Hashtbl.create 1024
 end
 
 let add_deps store t deps =
   let deps = Path.Set.of_list deps in
-  match Hashtbl.find store t with
+  match Hashtbl.find store t.name with
-  | None -> Hashtbl.add store ~key:t ~data:(ref deps)
+  | None ->
-  | Some r -> r := Path.Set.union deps !r
+    Hashtbl.add store ~key:t.name
+      ~data:{ Store.alias = t
+            ; deps = deps
+            }
+  | Some e -> e.deps <- Path.Set.union deps e.deps
 
 type tree = Node of Path.t * tree list
 
@@ -41,19 +68,29 @@ 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
+  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 : t))
+    ignore (setup_rec_alias store ~make_alias ~prefix ~tree : Path.t))
 
-let rules store ~prefix ~tree =
+let rules store ~prefixes ~tree =
-  setup_rec_aliases store ~prefix ~tree;
+  List.iter prefixes ~f:(fun prefix ->
-  Hashtbl.fold store ~init:[] ~f:(fun ~key:alias ~data:deps acc ->
+    setup_rec_aliases store ~prefix ~tree);
+
+  (* 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 (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.path_set deps >>>
-         Build.touch alias)
+         Build.touch alias.file)
     in
     rule :: acc)

src/alias.mli

@@ -4,6 +4,7 @@ val make : string -> dir:Path.t -> t
 
 val default : dir:Path.t -> t
 val runtest : dir:Path.t -> t
+val install : dir:Path.t -> t
 
 val dep : t -> ('a, 'a) Build.t
 val file : t -> Path.t
@@ -19,6 +20,6 @@ type tree = Node of Path.t * tree list
 
 val rules
   :  Store.t
-  -> prefix:Path.t
+  -> prefixes:Path.t list
   -> tree:tree
   -> Build_interpret.Rule.t list

src/gen_rules.ml

@@ -96,10 +96,10 @@ let obj_name_of_basename fn =
 module type Params = sig
   val context   : Context.t
   val file_tree : File_tree.t
-  val tree      : Alias.tree
   val stanzas   : (Path.t * Jbuild_types.Stanza.t list) list
   val packages  : Package.t String_map.t
   val filter_out_optional_stanzas_with_missing_deps : bool
+  val alias_store : Alias.Store.t
 end
 
 module Gen(P : Params) = struct
@@ -264,12 +264,9 @@ module Gen(P : Params) = struct
   module Alias = struct
     include Alias
 
-    let store = Store.create ()
+    let add_deps t deps = add_deps P.alias_store t deps
-    let add_deps t deps = add_deps store t deps
-    let rules () = rules store ~prefix:ctx.build_dir ~tree:P.tree
   end
 
-
   let all_rules = ref []
   let known_targets_by_dir_so_far = ref Path.Map.empty
 
@@ -1679,38 +1676,40 @@ module Gen(P : Params) = struct
     install_file pkg.Package.path pkg.name)
 
   let () =
-    let install_alias = Alias.make ~dir:ctx.build_dir "install" in
-    let global_install_alias = Alias.make ~dir:Path.root "install" in
     let is_default = Path.basename ctx.build_dir = "default" in
-    String_map.iter P.packages ~f:(fun ~key:pkg ~data:{ Package.path; _ } ->
+    String_map.iter P.packages ~f:(fun ~key:pkg ~data:{ Package.path = src_path; _ } ->
       let install_fn = pkg ^ ".install" in
-      let in_source_dir = Path.relative path install_fn in
+
-      let orig = Path.append ctx.build_dir in_source_dir in
+      let ctx_path = Path.append ctx.build_dir src_path in
-      let at_root_of_build_context = Path.relative ctx.build_dir install_fn in
+      let ctx_install_alias = Alias.install ~dir:ctx_path in
-      if not (Path.is_root path) then
+      let ctx_install_file = Path.relative ctx_path install_fn in
-        add_rule (Build.copy ~src:orig ~dst:at_root_of_build_context);
+      Alias.add_deps ctx_install_alias [ctx_install_file];
-      Alias.add_deps install_alias [at_root_of_build_context];
 
       if is_default then begin
-        add_rule (Build.copy ~src:orig ~dst:in_source_dir);
+        let src_install_alias = Alias.install ~dir:src_path in
-        let at_root = Path.relative Path.root install_fn in
+        let src_install_file = Path.relative src_path install_fn in
-        if not (Path.is_root path) then
+        add_rule (Build.copy ~src:ctx_install_file ~dst:src_install_file);
-          add_rule (Build.copy ~src:orig ~dst:at_root);
+        Alias.add_deps src_install_alias [src_install_file]
-        Alias.add_deps global_install_alias [at_root]
       end)
 end
 
-let gen ~context ~file_tree ~tree ~stanzas ~packages
+let gen ~contexts ~file_tree ~tree ~stanzas ~packages
-      ?(filter_out_optional_stanzas_with_missing_deps=true) () =
+    ?(filter_out_optional_stanzas_with_missing_deps=true) () =
-  let module M =
+  let alias_store = Alias.Store.create () in
-    Gen(struct
+  let rules =
-      let context  = context
+    List.concat_map contexts ~f:(fun context ->
-      let file_tree = file_tree
+        let module M =
-      let tree     = tree
+          Gen(struct
-      let stanzas  = stanzas
+            let context  = context
-      let packages = packages
+            let file_tree = file_tree
-      let filter_out_optional_stanzas_with_missing_deps =
+            let stanzas  = stanzas
-        filter_out_optional_stanzas_with_missing_deps
+            let packages = packages
-    end)
+            let filter_out_optional_stanzas_with_missing_deps =
+              filter_out_optional_stanzas_with_missing_deps
+            let alias_store = alias_store
+          end)
+        in
+        !M.all_rules)
   in
-  M.Alias.rules () @ !M.all_rules
+  Alias.rules alias_store ~prefixes:(Path.root :: List.map contexts ~f:(fun c -> c.Context.build_dir)) ~tree
+  @ rules

src/gen_rules.mli

@@ -1,7 +1,7 @@
 open Import
 
 val gen
-  :  context:Context.t
+  :  contexts:Context.t list
   -> file_tree:File_tree.t
   -> tree:Alias.tree
   -> stanzas:(Path.t * Jbuild_types.Stanza.t list) list

src/main.ml

@@ -28,9 +28,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps () =
    | Some c -> return c)
   >>= fun default_context ->
   let rules =
-    List.concat_map contexts ~f:(fun context ->
+    Gen_rules.gen ~contexts ~file_tree ~tree ~stanzas ~packages
-      Gen_rules.gen ~context ~file_tree ~tree ~stanzas ~packages
+      ?filter_out_optional_stanzas_with_missing_deps ()
-        ?filter_out_optional_stanzas_with_missing_deps ())
   in
   let build_system = Build_system.create ~file_tree ~rules in
   return { build_system