Make build system ask explicitly for install rules

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

src/build_system.ml

@@ -544,15 +544,28 @@ module Rule_fn = struct
   let loc () = Fdecl.get loc_decl ()
 end
 
+module Context_or_install = struct
+  type t =
+    | Install of string
+    | Context of string
+
+  let to_sexp = function
+    | Install ctx -> Sexp.List [ Sexp.Atom "install"; Sexp.Atom ctx ]
+    | Context s ->
+      assert (not (s = "install"));
+      Sexp.Atom s
+end
+
+
 type t =
   { (* File specification by targets *)
     files       : Internal_rule.t Path.Table.t
   ; contexts    : Context.t String.Map.t
   ; file_tree   : File_tree.t
   ; dirs : Dir_status.t Path.Table.t
   ; gen_rules :
-      (dir:Path.t -> string list -> extra_sub_directories_to_keep)
-        String.Map.t Fdecl.t
+      (Context_or_install.t ->
+       (dir:Path.t -> string list -> extra_sub_directories_to_keep) option) Fdecl.t
   ; mutable load_dir_stack : Path.t list
   ; (* Set of directories under _build that have at least one rule and
        all their ancestors. *)
@@ -590,7 +603,6 @@ let string_of_source_paths set =
 
 let set_rule_generators generators =
   let t = t () in
-  assert (String.Map.keys generators = String.Map.keys t.contexts);
   Fdecl.set t.gen_rules generators
 
 let get_dir_status t ~dir =
@@ -733,6 +745,14 @@ let no_rule_found =
           (Path.to_string_maybe_quoted fn)
           ctx
           (hint ctx (String.Map.keys t.contexts))
+    | Install (ctx, _) ->
+      if String.Map.mem t.contexts ctx then
+        fail fn ~loc
+      else
+        die "Trying to build %s for install but build context %s doesn't exist.%s"
+          (Path.to_string_maybe_quoted fn)
+          ctx
+          (hint ctx (String.Map.keys t.contexts))
     | Alias (ctx, fn') ->
       if String.Map.mem t.contexts ctx then
         fail fn ~loc
@@ -920,95 +940,110 @@ and load_dir_and_get_targets t ~dir =
       reraise exn
 
 and load_dir_step2_exn t ~dir ~collector =
-  let context_name, sub_dir = Path.extract_build_context_exn dir in
-  let is_install = context_name = "install" in
-  (* This condition is [true] because of [get_dir_status] *)
-  assert (is_install || String.Map.mem t.contexts context_name);
+  let context_name, sub_dir = match Utils.analyse_target dir with
+    | Install (ctx, path) ->
+      Context_or_install.Install ctx, path
+    | Regular (ctx, path) ->
+      Context_or_install.Context ctx, path
+    | Alias _ | Other _ ->
+      Exn.code_error "[load_dir_step2_exn] was called on a strange path"
+        ["path", (Path.to_sexp dir)]
+  in
 
   (* Load all the rules *)
   let extra_subdirs_to_keep =
-    if is_install then
-      These String.Set.empty
-    else
-      let gen_rules = String.Map.find_exn (Fdecl.get t.gen_rules) context_name in
-      handle_add_rule_effects
-        (fun () ->
-           gen_rules ~dir (Path.Source.explode sub_dir))
+    let gen_rules =
+      match (Fdecl.get t.gen_rules) context_name with
+      | None ->
+        Exn.code_error "[gen_rules] did not specify rules for the context"
+          ["context_name", (Context_or_install.to_sexp context_name)]
+      | Some rules ->
+        rules
+    in
+    handle_add_rule_effects (fun () -> gen_rules ~dir (Path.Source.explode sub_dir))
   in
   let collector = Dir_status.Rules_collector.freeze collector in
   let rules = Dir_status.Rules_collector.rules collector in
 
   (* Compute alias rules *)
-  let alias_dir = Path.append_source (Path.relative alias_dir context_name) sub_dir in
-  let alias_rules, alias_stamp_files =
-    let open Build.O in
-    let aliases =
-      Dir_status.Rules_collector.aliases collector
-    in
-    let aliases =
-      if String.Map.mem aliases "default" then
-        aliases
-      else
-        match Path.extract_build_context_dir dir with
-        | None -> aliases
-        | Some (ctx_dir, src_dir) ->
-          match File_tree.find_dir t.file_tree src_dir with
-          | None -> aliases
-          | Some dir ->
-            String.Map.add aliases "default"
-              ({ deps = Path.Set.empty
-               ; dyn_deps =
-                   (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir
-                    >>^ fun (_ : bool) ->
-                    Path.Set.empty)
-               ; actions = []
-               } : Dir_status.Alias.immutable)
-    in
-    String.Map.foldi aliases ~init:([], Path.Set.empty)
-      ~f:(fun name { Dir_status.Alias.deps; dyn_deps; actions } (rules, alias_stamp_files) ->
-        let base_path = Path.relative alias_dir name in
-        let rules, action_stamp_files =
-          List.fold_left actions ~init:(rules, Path.Set.empty)
-            ~f:(fun (rules, action_stamp_files)
-                 { Dir_status. stamp; action; locks ; context ; loc ; env } ->
-                 let path =
-                   Path.extend_basename base_path
-                     ~suffix:("-" ^ Digest.to_string stamp)
-                 in
-                 let rule =
-                   Pre_rule.make ~locks ~context:(Some context) ~env
-                     ~info:(Rule.Info.of_loc_opt loc)
-                     (Build.progn [ action; Build.create_file path ])
-                 in
-                 (rule :: rules, Path.Set.add action_stamp_files path))
+  let alias_dir, alias_rules =
+    match context_name with
+    | Context context_name ->
+      let alias_dir = Path.append_source (Path.relative alias_dir context_name) sub_dir in
+      let alias_rules, alias_stamp_files =
+        let open Build.O in
+        let aliases =
+          Dir_status.Rules_collector.aliases collector
         in
-        let deps = Path.Set.union deps action_stamp_files in
-        let path = Path.extend_basename base_path ~suffix:Alias0.suffix in
-        let targets =
-          Path.Set.add action_stamp_files path
-          |> Path.Set.union alias_stamp_files
+        let aliases =
+          if String.Map.mem aliases "default" then
+            aliases
+          else
+            match Path.extract_build_context_dir dir with
+            | None -> aliases
+            | Some (ctx_dir, src_dir) ->
+              match File_tree.find_dir t.file_tree src_dir with
+              | None -> aliases
+              | Some dir ->
+                String.Map.add aliases "default"
+                  { deps = Path.Set.empty
+                  ; dyn_deps =
+                      (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir
+                       >>^ fun (_ : bool) ->
+                       Path.Set.empty)
+                  ; actions = []
+                  }
         in
-        (Pre_rule.make
-           ~context:None
-           ~env:None
-           (Build.path_set deps >>>
-            dyn_deps >>>
-            Build.dyn_path_set (Build.arr Fn.id)
-            >>^ (fun dyn_deps ->
-              let deps = Path.Set.union deps dyn_deps in
-              Action.with_stdout_to path
-                (Action.digest_files (Path.Set.to_list deps)))
-            >>>
-            Build.action_dyn () ~targets:[path])
-         :: rules,
-         targets))
+        String.Map.foldi aliases ~init:([], Path.Set.empty)
+          ~f:(fun name { Dir_status.Alias. deps; dyn_deps; actions } (rules, alias_stamp_files) ->
+            let base_path = Path.relative alias_dir name in
+            let rules, action_stamp_files =
+              List.fold_left actions ~init:(rules, Path.Set.empty)
+                ~f:(fun (rules, action_stamp_files)
+                     { Dir_status. stamp; action; locks ; context ; loc ; env } ->
+                     let path =
+                       Path.extend_basename base_path
+                         ~suffix:("-" ^ Digest.to_string stamp)
+                     in
+                     let rule =
+                       Pre_rule.make ~locks ~context:(Some context) ~env
+                         ~info:(Rule.Info.of_loc_opt loc)
+                         (Build.progn [ action; Build.create_file path ])
+                     in
+                     (rule :: rules, Path.Set.add action_stamp_files path))
+            in
+            let deps = Path.Set.union deps action_stamp_files in
+            let path = Path.extend_basename base_path ~suffix:Alias0.suffix in
+            let targets =
+              Path.Set.add action_stamp_files path
+              |> Path.Set.union alias_stamp_files
+            in
+            (Pre_rule.make
+               ~context:None
+               ~env:None
+               (Build.path_set deps >>>
+                dyn_deps >>>
+                Build.dyn_path_set (Build.arr Fn.id)
+                >>^ (fun dyn_deps ->
+                  let deps = Path.Set.union deps dyn_deps in
+                  Action.with_stdout_to path
+                    (Action.digest_files (Path.Set.to_list deps)))
+                >>>
+                Build.action_dyn () ~targets:[path])
+             :: rules,
+             targets))
+      in
+      Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files);
+      Some alias_dir, alias_rules
+    | Install _ ->
+      None, []
   in
-  Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files);
 
   let file_tree_dir =
-    if is_install then
+    match context_name with
+    | Install _ ->
       None
-    else
+    | Context _ ->
       File_tree.find_dir t.file_tree sub_dir
   in
 
@@ -1042,11 +1077,14 @@ and load_dir_step2_exn t ~dir ~collector =
   in
   (* Take into account the source files *)
   let targets, to_copy, subdirs_to_keep =
-    if is_install then
+    match context_name with
+    | Install _ ->
       (user_rule_targets,
        None,
        String.Set.empty)
-    else
+    | Context context_name ->
+      (* This condition is [true] because of [get_dir_status] *)
+      assert (String.Map.mem t.contexts context_name);
       let files, subdirs =
         match file_tree_dir with
         | None -> (Path.Source.Set.empty, String.Set.empty)
@@ -1145,7 +1183,8 @@ The following targets are not:
   remove_old_artifacts t ~dir ~subdirs_to_keep;
 
   List.iter alias_rules ~f:(compile_rule t);
-  remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep;
+  Option.iter alias_dir ~f:(fun alias_dir ->
+    remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep);
 
   targets
 

src/build_system.mli

@@ -24,11 +24,19 @@ type extra_sub_directories_to_keep =
   | All
   | These of String.Set.t
 
+module Context_or_install : sig
+  type t =
+    | Install of string
+    | Context of string
+
+  val to_sexp : t -> Sexp.t
+end
+
 (** 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
+    in the corresponding build context. It receives the directory for
     which to generate the rules and the split 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
@@ -37,8 +45,9 @@ type extra_sub_directories_to_keep =
     It is expected that [f] only generate rules whose targets are
     descendant of [dir]. *)
 val set_rule_generators
-  :  (dir:Path.t -> string list -> extra_sub_directories_to_keep)
-       String.Map.t -> unit
+  :  (Context_or_install.t ->
+      (dir:Path.t -> string list -> extra_sub_directories_to_keep) option)
+  -> unit
 
 (** All other functions in this section must be called inside the rule generator
     callback. *)

src/gen_rules.ml

@@ -344,8 +344,11 @@ let gen ~contexts
   in
   let+ contexts = Fiber.parallel_map contexts ~f:make_sctx in
   let map = String.Map.of_list_exn contexts in
+  let generators = (String.Map.map map ~f:(fun (module M : Gen) -> M.gen_rules)) in
   Build_system.set_rule_generators
-    (String.Map.map map ~f:(fun (module M : Gen) -> M.gen_rules));
+    (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);
 

src/process.ml

@@ -204,6 +204,9 @@ module Fancy = struct
           | Alias (ctx, name) ->
             split_paths (("alias " ^ Path.Source.to_string name) :: targets_acc)
               (add_ctx ctx ctxs_acc) rest
+          | Install (ctx, name) ->
+            split_paths (("install " ^ Path.Source.to_string name) :: targets_acc)
+              (add_ctx ctx ctxs_acc) rest
       in
       let targets = Path.Set.to_list targets in
       let target_names, contexts = split_paths [] [] targets in

src/utils.ml

@@ -68,30 +68,36 @@ let signal_name =
 type target_kind =
   | Regular of string * Path.Source.t
   | Alias   of string * Path.Source.t
+  | Install of string * Path.Source.t
   | Other of Path.t
 
 let analyse_target (fn as original_fn) =
   match Path.extract_build_dir_first_component fn with
-  | Some (".aliases", sub) -> begin
-      match Path.Relative.split_first_component sub with
-      | None -> Other fn
-      | Some (ctx, fn) ->
-        if Path.Relative.is_root fn then
-          Other original_fn
-        else
-          let basename =
-            match String.rsplit2 (Path.Relative.basename fn) ~on:'-' with
-            | None -> assert false
-            | Some (name, digest) ->
-              assert (String.length digest = 32);
-              name
-          in
-          Alias (ctx,
-                 Path.Source.of_relative
-                   (Path.Relative.relative (Path.Relative.parent_exn fn) basename))
-    end
-  | Some ("install", _) -> Other fn
-  | Some (ctx, sub) -> Regular (ctx, Path.Source.of_relative sub)
+  | Some (".aliases", sub) ->
+    (match Path.Relative.split_first_component sub with
+    | None -> Other fn
+    | Some (ctx, fn) ->
+      if Path.Relative.is_root fn then
+        Other original_fn
+      else
+        let basename =
+          match String.rsplit2 (Path.Relative.basename fn) ~on:'-' with
+          | None -> assert false
+          | Some (name, digest) ->
+            assert (String.length digest = 32);
+            name
+        in
+        Alias (ctx,
+               Path.Source.relative
+                 (Path.Source.of_relative (Path.Relative.parent_exn fn))
+                 basename))
+  | Some ("install", sub) ->
+    (match Path.Relative.split_first_component sub with
+    | None -> Other fn
+    | Some (ctx, fn) ->
+      Install (ctx, Path.Source.of_relative fn))
+  | Some (ctx, sub) ->
+    Regular (ctx, Path.Source.of_relative sub)
   | None ->
     Other fn
 
@@ -103,6 +109,8 @@ let describe_target fn =
   match analyse_target fn with
   | Alias (ctx, p) ->
     sprintf "alias %s%s" (Path.Source.to_string_maybe_quoted p) (ctx_suffix ctx)
+  | Install (ctx, p) ->
+    sprintf "install %s%s" (Path.Source.to_string_maybe_quoted p) (ctx_suffix ctx)
   | Regular (ctx, fn) ->
     sprintf "%s%s" (Path.Source.to_string_maybe_quoted fn) (ctx_suffix ctx)
   | Other fn ->

src/utils.mli

@@ -40,6 +40,7 @@ val executable_object_directory
 type target_kind =
   | Regular of string (* build context *) * Path.Source.t
   | Alias   of string (* build context *) * Path.Source.t
+  | Install of string (* build context *) * Path.Source.t
   | Other of Path.t
 
 (** Return the name of an alias from its stamp file *)