feature: Redirect_to_parent improved

now it allows generating rules in addition to redirecting

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

src/dune_engine/build_config.ml

@@ -17,10 +17,28 @@ type rules =
   ; rules : Rules.t Memo.t
   }
 
+let empty_rules =
+  { build_dir_only_sub_dirs = Subdir_set.empty
+  ; directory_targets = Path.Build.Map.empty
+  ; rules = Memo.return Rules.empty
+  }
+
+let combine_rules 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')
+  }
+
 type gen_rules_result =
   | Rules of rules
   | Unknown_context_or_install
-  | Redirect_to_parent
+  | Redirect_to_parent of rules
 
 module type Rule_generator = sig
   val gen_rules :

src/dune_engine/build_config.mli

@@ -33,10 +33,14 @@ type rules =
   ; rules : Rules.t Memo.t
   }
 
+val empty_rules : rules
+
+val combine_rules : rules -> rules -> rules
+
 type gen_rules_result =
   | Rules of rules
   | Unknown_context_or_install
-  | Redirect_to_parent
+  | Redirect_to_parent of rules
       (** [Redirect_to_parent] means that the parent will generate the rules for
           this directory. *)
 

src/dune_engine/load_rules.ml

@@ -497,12 +497,34 @@ end = struct
         ~subdir:(Path.Build.basename dir)
   end
 
+  type normal =
+    { build_dir_only_sub_dirs : Subdir_set.t
+    ; directory_targets : Loc.t Path.Build.Map.t
+    ; rules : Rules.t Memo.Lazy.t
+    }
+
   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
+    | Normal of normal
+
+  let combine_gen_rules_result ~parent ~child =
+    match parent with
+    | Under_directory_target _ ->
+      (* we aren't allowed rules under a directory target *)
+      assert false
+    | Normal r ->
+      let { build_dir_only_sub_dirs; directory_targets; rules } = child in
+      Normal
+        { 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
@@ -553,36 +575,42 @@ end = struct
                       ] )) )
           ]
 
+    let make_rules_gen_result ~of_
+        { Build_config.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 }
+
     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 (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 = 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

@@ -374,7 +374,8 @@ let has_rules subdirs f =
        ; rules
        })
 
-let redirect_to_parent = Memo.return Build_config.Redirect_to_parent
+let redirect_to_parent =
+  Memo.return (Build_config.Redirect_to_parent Build_config.empty_rules)
 
 (* Once [gen_rules] has decided what to do with the directory, it should end
    with [has_rules] or [redirect_to_parent] *)

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.empty_rules)