Use [Scheme] for install rules

Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>

src/build_system.ml

@@ -573,7 +573,7 @@ type t =
   ; mutable prefix : (unit, unit) Build.t option
   ; hook : hook -> unit
   ; (* Package files are part of *)
-    packages : Package.Name.t Path.Table.t
+    packages : (Path.t -> Package.Name.t list) Fdecl.t
   }
 
 let t = ref None
@@ -1571,7 +1571,7 @@ let init ~contexts ~file_tree ~hook =
   set
     { contexts
     ; files      = Path.Table.create 1024
-    ; packages   = Path.Table.create 1024
+    ; packages   = Fdecl.create ()
     ; dirs       = Path.Table.create 1024
     ; load_dir_stack = []
     ; file_tree
@@ -1598,9 +1598,9 @@ module Rule = struct
   module Set = Set.Make(struct type nonrec t = t let compare = compare end)
 end
 
-let set_package file package =
+let set_packages f =
   let t = t () in
-  Path.Table.add t.packages file package
+  Fdecl.set t.packages f
 
 let package_deps pkg files =
   let t = t () in
@@ -1613,7 +1613,7 @@ let package_deps pkg files =
       Package.Name.Set.add acc p
   in
   let rec loop fn acc =
-    match Path.Table.find_all t.packages fn with
+    match Fdecl.get t.packages fn with
     | [] -> loop_deps fn acc
     | pkgs ->
       if List.mem pkg ~set:pkgs then

src/build_system.mli

@@ -84,8 +84,8 @@ val targets_of : dir:Path.t -> Path.Set.t
 (** Load the rules for this directory. *)
 val load_dir : dir:Path.t -> unit
 
-(** Sets the package this file is part of *)
-val set_package : Path.t -> Package.Name.t -> unit
+(** Sets the package assignment *)
+val set_packages : (Path.t -> Package.Name.t list) -> unit
 
 (** Assuming [files] is the list of files in [_build/install] that
     belong to package [pkg], [package_deps t pkg files] is the set of

src/dir_set.ml

@@ -92,7 +92,7 @@ let rec intersect x y =
   match T.match_ x, T.match_ y with
   | `Universal, _ -> y
   | _, `Universal -> x
-  | `Empty, _ | _, `Empty -> T.universal
+  | `Empty, _ | _, `Empty -> T.empty
   | `Nontrivial _, `Nontrivial _ ->
     { here = x.here && y.here;
       children = intersect_children x.children y.children;
@@ -167,5 +167,30 @@ let of_individual_dirs paths =
   List.map paths ~f:(of_subtree_gen just_the_root)
   |> union_all
 
+type element =
+  | One_dir of Path.t
+  | Subtree of Path.t
+
+let of_list list =
+  List.map list ~f:(function
+    | One_dir dir -> of_subtree_gen just_the_root dir
+    | Subtree dir -> of_subtree_gen T.universal dir)
+  |> union_all
+
 let is_subset x ~of_ =
   is_empty (intersect x (negate of_))
+
+let rec to_sexp t = match match_ t with
+  | `Empty -> Sexp.Atom "Empty"
+  | `Universal -> Sexp.Atom "Universal"
+  | `Nontrivial _ ->
+    Sexp.List (
+      (
+        (match t.here with | true -> [ ".", Sexp.Atom "true" ] | false -> []) @
+        (String.Map.to_list t.children.exceptions
+         |> List.map ~f:(fun (s, t) ->
+           s, to_sexp t)) @
+        (match t.children.default with
+         | false -> []
+         | true -> [("*", Sexp.Atom "Universal")]))
+      |> List.map ~f:(fun (k, v) -> Sexp.List [Sexp.Atom k; v]))

src/dir_set.mli

@@ -36,4 +36,16 @@ val descend : t -> string -> t
 val of_subtrees : Path.t list -> t
 val of_individual_dirs : Path.t list -> t
 
+type element =
+  | One_dir of Path.t
+  | Subtree of Path.t
+
+val of_list : element list -> t
+
 val is_subset : t -> of_:t -> bool
+
+val union : t -> t -> t
+val intersect : t -> t -> t
+val negate : t -> t
+
+val to_sexp : t -> Sexp.t

src/gen_rules.ml

@@ -220,6 +220,7 @@ module Gen(P : sig val sctx : Super_context.t end) = struct
   let gen_rules ~dir components : Build_system.extra_sub_directories_to_keep =
     Install_rules.init_meta sctx ~dir;
     Opam_create.add_rules sctx ~dir;
+    Install_rules.gen_rules sctx ~dir;
     (match components with
      | ".js"  :: rest -> Js_of_ocaml_rules.setup_separate_compilation_rules
                            sctx rest
@@ -271,18 +272,13 @@ module Gen(P : sig val sctx : Super_context.t end) = struct
     | [(".js"|"_doc"|".ppx")] -> All
     | _  -> These String.Set.empty
 
-  let init () =
-    Install_rules.init sctx;
-    Build_system.handle_add_rule_effects (fun () ->
-      Odoc.init sctx)
 end
 
 module type Gen = sig
   val gen_rules
     :  dir:Path.t
     -> string list
     -> Build_system.extra_sub_directories_to_keep
-  val init : unit -> unit
   val sctx : Super_context.t
 end
 
@@ -344,11 +340,34 @@ let gen ~contexts
   in
   let+ contexts = Fiber.parallel_map contexts ~f:make_sctx in
   let map = String.Map.of_list_exn contexts in
+  let sctxs = String.Map.map map ~f:(fun (module M : Gen) -> M.sctx) in
   let generators = (String.Map.map map ~f:(fun (module M : Gen) -> M.gen_rules)) in
+  let () =
+    let compute_packages = Memo.lazy_ (fun () ->
+      String.Map.to_list sctxs
+      |> List.concat_map ~f:(fun (_, sctx) ->
+        Install_rules.packages sctx
+        |> Path.Map.to_list)
+      (* [_exn] here relies on the fact that there are no paths that belong to more than
+         one context *)
+      |> Path.Map.of_list_exn)
+    in
+    Build_system.set_packages (fun path ->
+      match Path.Map.find (Memo.Lazy.force compute_packages) path with
+      | None -> []
+      | Some pkg -> [ pkg ])
+  in
   Build_system.set_rule_generators
     (function
-      | Install _ctx -> Some (fun ~dir:_ _path -> These String.Set.empty)
-      | Context ctx -> String.Map.find generators ctx);
-  String.Map.iter map ~f:(fun (module M : Gen) -> M.init ());
-  String.Map.map map ~f:(fun (module M : Gen) -> M.sctx);
+      | Install ctx ->
+        Option.map (String.Map.find sctxs ctx) ~f:(fun sctx ->
+          (fun ~dir _ ->
+             Install_rules.gen_rules sctx ~dir;
+             Build_system.These String.Set.empty))
+      | Context ctx ->
+        String.Map.find generators ctx);
 
+  String.Map.iter map ~f:(fun (module M : Gen) ->
+    Build_system.handle_add_rule_effects (fun () ->
+      Odoc.init M.sctx));
+  sctxs