feature: Redirect_to_parent improved

src/dune_engine/build_config.ml

@@ -11,16 +11,36 @@ module Context_or_install = struct
     | Context s -> Context_name.to_dyn s
 end
 
-type rules =
-  { build_dir_only_sub_dirs : Subdir_set.t
-  ; directory_targets : Loc.t Path.Build.Map.t
-  ; rules : Rules.t Memo.t
-  }
+module Rules = struct
+  type t =
+    { build_dir_only_sub_dirs : Subdir_set.t
+    ; directory_targets : Loc.t Path.Build.Map.t
+    ; rules : Rules.t Memo.t
+    }
+
+  let empty =
+    { build_dir_only_sub_dirs = Subdir_set.empty
+    ; directory_targets = Path.Build.Map.empty
+    ; rules = Memo.return Rules.empty
+    }
+
+  let combine_exn r { build_dir_only_sub_dirs; directory_targets; rules } =
+    { build_dir_only_sub_dirs =
+        Subdir_set.union r.build_dir_only_sub_dirs build_dir_only_sub_dirs
+    ; directory_targets =
+        Path.Build.Map.union_exn r.directory_targets directory_targets
+    ; rules =
+        (let open Memo.O in
+        let+ r = r.rules
+        and+ r' = rules in
+        Rules.union r r')
+    }
+end
 
 type gen_rules_result =
-  | Rules of rules
+  | Rules of Rules.t
   | Unknown_context_or_install
-  | Redirect_to_parent
+  | Redirect_to_parent of Rules.t
 
 module type Rule_generator = sig
   val gen_rules :

src/dune_engine/build_config.mli

@@ -12,33 +12,40 @@ module Context_or_install : sig
   val to_dyn : t -> Dyn.t
 end
 
-(** Rules for a given directory. This type is structured so that all generated
-    sub-directories (either directory targets or internal generated directories
-    such as [.ppx]) are known immediately, while the actual build rules are
-    computed in a second stage. The staging is to avoid computation cycles
-    created during the computation of the rules. *)
-type rules =
-  { build_dir_only_sub_dirs : Subdir_set.t
-        (** Sub-directories that don't exist in the source tree but exists in
-            the build directory. This is for internal directories such as
-            [.dune] or [.ppx]. *)
-  ; directory_targets : Loc.t Path.Build.Map.t
-        (** Directories that are target of a rule. For each directory target,
-            give the location of the rule that generates it. The keys in this
-            map must correspond exactly to the set of directory targets that
-            will be produces by [rules]. The values should be the locations of
-            the rules that are going to produce these targets. However, it's ok
-            to have an approximate location as the rule that produces the target
-            will be responsible for producing the final location*)
-  ; rules : Rules.t Memo.t
-  }
+module Rules : sig
+  (** Rules for a given directory. This type is structured so that all generated
+      sub-directories (either directory targets or internal generated
+      directories such as [.ppx]) are known immediately, while the actual build
+      rules are computed in a second stage. The staging is to avoid computation
+      cycles created during the computation of the rules. *)
+
+  type t =
+    { build_dir_only_sub_dirs : Subdir_set.t
+          (** Sub-directories that don't exist in the source tree but exists in
+              the build directory. This is for internal directories such as
+              [.dune] or [.ppx]. *)
+    ; directory_targets : Loc.t Path.Build.Map.t
+          (** Directories that are target of a rule. For each directory target,
+              give the location of the rule that generates it. The keys in this
+              map must correspond exactly to the set of directory targets that
+              will be produces by [rules]. The values should be the locations of
+              the rules that are going to produce these targets. However, it's
+              ok to have an approximate location as the rule that produces the
+              target will be responsible for producing the final location*)
+    ; rules : Rules.t Memo.t
+    }
+
+  val empty : t
+
+  (** Raises a code error if there are multiple rules for the same target. *)
+  val combine_exn : t -> t -> t
+end
 
 type gen_rules_result =
-  | Rules of rules
+  | Rules of Rules.t
   | Unknown_context_or_install
-  | Redirect_to_parent
-      (** [Redirect_to_parent] means that the parent will generate the rules for
-          this directory. *)
+  | Redirect_to_parent of Rules.t
+      (** [Redirect_to_parent rules] lets the parent add more rules to [rules]. *)
 
 module type Rule_generator = sig
   (** The rule generator.

src/dune_engine/load_rules.ml

@@ -497,17 +497,26 @@ end = struct
         ~subdir:(Path.Build.basename dir)
   end
 
-  type gen_rules_result =
-    | Under_directory_target of { directory_target_ancestor : Path.Build.t }
-    | Normal of
-        { build_dir_only_sub_dirs : Subdir_set.t
-        ; directory_targets : Loc.t Path.Build.Map.t
-        ; rules : Rules.t Memo.Lazy.t
-        }
+  module Normal = struct
+    type t =
+      { build_dir_only_sub_dirs : Subdir_set.t
+      ; directory_targets : Loc.t Path.Build.Map.t
+      ; rules : Rules.t Memo.Lazy.t
+      }
+
+    let combine_exn r { build_dir_only_sub_dirs; directory_targets; rules } =
+      { build_dir_only_sub_dirs =
+          Subdir_set.union r.build_dir_only_sub_dirs build_dir_only_sub_dirs
+      ; directory_targets =
+          Path.Build.Map.union_exn r.directory_targets directory_targets
+      ; rules =
+          Memo.lazy_ (fun () ->
+              let open Memo.O in
+              let+ r = Memo.Lazy.force r.rules
+              and+ r' = Memo.Lazy.force rules in
+              Rules.union r r')
+      }
 
-  module rec Gen_rules : sig
-    val gen_rules : Dir_triage.Build_directory.t -> gen_rules_result Memo.t
-  end = struct
     let check_all_directory_targets_are_descendant ~of_:dir directory_targets =
       Path.Build.Map.iteri directory_targets ~f:(fun p _loc ->
           if not (Path.Build.is_descendant p ~of_:dir) then
@@ -553,36 +562,60 @@ end = struct
                       ] )) )
           ]
 
+    let make_rules_gen_result ~of_
+        { Build_config.Rules.build_dir_only_sub_dirs; directory_targets; rules }
+        =
+      check_all_directory_targets_are_descendant ~of_ directory_targets;
+      let rules =
+        Memo.lazy_ (fun () ->
+            let+ rules = rules in
+            check_all_rules_are_descendant ~of_ rules;
+            rules)
+      in
+      { build_dir_only_sub_dirs; directory_targets; rules }
+  end
+
+  type gen_rules_result =
+    | Under_directory_target of { directory_target_ancestor : Path.Build.t }
+    | Normal of Normal.t
+
+  module rec Gen_rules : sig
+    val gen_rules : Dir_triage.Build_directory.t -> gen_rules_result Memo.t
+  end = struct
+    let combine_gen_rules_result ~parent ~child =
+      match parent with
+      | Under_directory_target { directory_target_ancestor } ->
+        Code_error.raise "rules under a directory target aren't allowed"
+          [ ( "directory_target_ancestor"
+            , Path.Build.to_dyn directory_target_ancestor )
+          ]
+      | Normal r -> Normal (Normal.combine_exn r child)
+
     let call_rules_generator
         ({ Dir_triage.Build_directory.dir; context_or_install; sub_dir } as d) =
       let (module RG : Build_config.Rule_generator) =
         (Build_config.get ()).rule_generator
       in
       let sub_dir_components = Path.Source.explode sub_dir in
       RG.gen_rules context_or_install ~dir sub_dir_components >>= function
-      | Rules { build_dir_only_sub_dirs; directory_targets; rules } ->
-        check_all_directory_targets_are_descendant ~of_:dir directory_targets;
-        let rules =
-          Memo.lazy_ (fun () ->
-              let+ rules = rules in
-              check_all_rules_are_descendant ~of_:dir rules;
-              rules)
-        in
-        Memo.return
-          (Normal { build_dir_only_sub_dirs; directory_targets; rules })
+      | Rules rules ->
+        Memo.return @@ Normal (Normal.make_rules_gen_result ~of_:dir rules)
       | Unknown_context_or_install ->
         Code_error.raise "[gen_rules] did not specify rules for the context"
           [ ("context_or_install", Context_or_install.to_dyn context_or_install)
           ]
-      | Redirect_to_parent -> (
+      | Redirect_to_parent child -> (
         match Dir_triage.Build_directory.parent d with
         | None ->
           Code_error.raise
             "[gen_rules] returned Redirect_to_parent on a root directory"
             [ ( "context_or_install"
               , Context_or_install.to_dyn context_or_install )
             ]
-        | Some d' -> Gen_rules.gen_rules d')
+        | Some parent ->
+          let child = Normal.make_rules_gen_result ~of_:dir child in
+          let+ parent = Gen_rules.gen_rules parent in
+          combine_gen_rules_result ~parent ~child)
 
     let gen_rules_impl d =
       match Dir_triage.Build_directory.parent d with

src/dune_rules/gen_rules.ml

@@ -392,7 +392,8 @@ let rec has_melange_emit_parent dir =
       | true -> Memo.return true
       | false -> has_melange_emit_parent parent_dir))
 
-let redirect_to_parent = Memo.return Build_config.Redirect_to_parent
+let redirect_to_parent =
+  Memo.return (Build_config.Redirect_to_parent Build_config.Rules.empty)
 
 (* Once [gen_rules] has decided what to do with the directory, it should end
    with [has_rules] or [redirect_to_parent] *)
@@ -499,7 +500,7 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t =
         else
           Memo.return
             (Build_config.Rules
-               { Build_config.build_dir_only_sub_dirs = S.These subdirs
+               { Build_config.Rules.build_dir_only_sub_dirs = S.These subdirs
                ; directory_targets
                ; rules
                })))

src/dune_rules/odoc.ml

@@ -899,4 +899,4 @@ let gen_rules sctx ~dir:_ rest =
            setup_pkg_html_rules name
        in
        ())
-  | _ -> Memo.return Build_config.Redirect_to_parent
+  | _ -> Memo.return (Build_config.Redirect_to_parent Build_config.Rules.empty)