fix(rules): merge allowed subdirs correctly for Redirect_to_parent ru…

…les (#7207)

* fix(rules): merge allowed subdirs correctly for Redirect_to_parent rules

src/dune_engine/build_config.ml

@@ -12,21 +12,36 @@ module Context_or_install = struct
 end
 
 module Rules = struct
+  module Build_only_sub_dirs = struct
+    type t = Subdir_set.t Path.Build.Map.t
+
+    let empty = Path.Build.Map.empty
+
+    let singleton ~dir sub_dirs = Path.Build.Map.singleton dir sub_dirs
+
+    let find t dir =
+      Path.Build.Map.find t dir |> Option.value ~default:Subdir_set.empty
+
+    let union a b =
+      Path.Build.Map.union a b ~f:(fun _ a b -> Some (Subdir_set.union a b))
+  end
+
   type t =
-    { build_dir_only_sub_dirs : Subdir_set.t
+    { build_dir_only_sub_dirs : Build_only_sub_dirs.t
     ; directory_targets : Loc.t Path.Build.Map.t
     ; rules : Rules.t Memo.t
     }
 
   let empty =
-    { build_dir_only_sub_dirs = Subdir_set.empty
+    { build_dir_only_sub_dirs = Path.Build.Map.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
+        Build_only_sub_dirs.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 =

src/dune_engine/build_config.mli

@@ -14,13 +14,27 @@ end
 
 module Rules : sig
   (** Rules for a given directory. This type is structured so that all generated
-      sub-directories (either directory targets or internal generated
+      sub-directories (either directory targets or internally 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. *)
 
+  module Build_only_sub_dirs : sig
+    (** The set of either directory targets or internally generated directories,
+        indexed by their parent build directory. *)
+    type t
+
+    val empty : t
+
+    val singleton : dir:Path.Build.t -> Subdir_set.t -> t
+
+    val find : t -> Path.Build.t -> Subdir_set.t
+
+    val union : t -> t -> t
+  end
+
   type t =
-    { build_dir_only_sub_dirs : Subdir_set.t
+    { build_dir_only_sub_dirs : Build_only_sub_dirs.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]. *)

src/dune_engine/load_rules.ml

@@ -501,14 +501,15 @@ end = struct
 
   module Normal = struct
     type t =
-      { build_dir_only_sub_dirs : Subdir_set.t
+      { build_dir_only_sub_dirs : Build_config.Rules.Build_only_sub_dirs.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
+          Build_config.Rules.Build_only_sub_dirs.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 =
@@ -529,6 +530,17 @@ end = struct
               ; ("example", Path.Build.to_dyn p)
               ])
 
+    let check_all_sub_dirs_rule_dirs_are_descendant ~of_:dir
+        build_dir_only_sub_dirs =
+      Path.Build.Map.iteri build_dir_only_sub_dirs ~f:(fun p _sub_dirs ->
+          if not (Path.Build.is_descendant p ~of_:dir) then
+            Code_error.raise
+              "[gen_rules] returned sub-directories in a directory that is not \
+               a descendant of the directory it was called for"
+              [ ("dir", Path.Build.to_dyn dir)
+              ; ("example", Path.Build.to_dyn p)
+              ])
+
     let check_all_rules_are_descendant ~of_:dir rules =
       match
         Path.Build.Map.find_key (Rules.to_map rules) ~f:(fun p ->
@@ -568,6 +580,7 @@ end = struct
         { Build_config.Rules.build_dir_only_sub_dirs; directory_targets; rules }
         =
       check_all_directory_targets_are_descendant ~of_ directory_targets;
+      check_all_sub_dirs_rule_dirs_are_descendant ~of_ directory_targets;
       let rules =
         Memo.lazy_ (fun () ->
             let+ rules = rules in
@@ -660,6 +673,9 @@ end = struct
       Memo.return
         (Loaded.Build_under_directory_target { directory_target_ancestor })
     | Normal { rules; build_dir_only_sub_dirs; directory_targets } ->
+      let build_dir_only_sub_dirs =
+        Build_config.Rules.Build_only_sub_dirs.find build_dir_only_sub_dirs dir
+      in
       Path.Build.Map.iteri directory_targets ~f:(fun dir_target loc ->
           let name = Path.Build.basename dir_target in
           if

src/dune_rules/gen_rules.ml

@@ -350,6 +350,13 @@ let automatic_sub_dirs_map =
     ; (Artifacts.Bin.bin_dir_basename, Bin)
     ]
 
+let automatic_subdirs components =
+  match List.last components with
+  | None -> String.Set.of_keys automatic_sub_dirs_map
+  | Some comp ->
+    if String.Map.mem automatic_sub_dirs_map comp then String.Set.empty
+    else String.Set.of_keys automatic_sub_dirs_map
+
 let gen_rules_for_automatic_sub_dir ~sctx ~dir kind =
   match kind with
   | Utop -> Utop.setup sctx ~dir:(Path.Build.parent_exn dir)
@@ -364,11 +371,12 @@ let gen_rules_for_automatic_sub_dir ~sctx ~dir kind =
         let dst = File_binding.Expanded.dst_path t ~dir in
         Super_context.add_rule sctx ~loc ~dir (Action_builder.symlink ~src ~dst))
 
-let has_rules subdirs f =
+let has_rules ~dir subdirs f =
   let rules = Rules.collect_unit f in
   Memo.return
     (Build_config.Rules
-       { build_dir_only_sub_dirs = subdirs
+       { build_dir_only_sub_dirs =
+           Build_config.Rules.Build_only_sub_dirs.singleton ~dir subdirs
        ; directory_targets = Path.Build.Map.empty
        ; rules
        })
@@ -406,18 +414,11 @@ let rec under_melange_emit_target ~dir =
       | Some stanza -> Memo.return @@ Some { stanza_dir = parent; stanza }))
 
 let melange_emit_rules sctx { stanza_dir; stanza } =
-  let rules =
-    Rules.collect_unit (fun () ->
-        let* dir_contents = Dir_contents.get sctx ~dir:stanza_dir in
-        let* scope = Scope.DB.find_by_dir stanza_dir in
-        Melange_rules.setup_emit_js_rules ~dir_contents ~dir:stanza_dir ~scope
-          ~sctx stanza)
-  in
-  { Build_config.Rules.build_dir_only_sub_dirs =
-      Subdir_set.These (String.Set.of_keys automatic_sub_dirs_map)
-  ; directory_targets = Path.Build.Map.empty
-  ; rules
-  }
+  Rules.collect_unit (fun () ->
+      let* dir_contents = Dir_contents.get sctx ~dir:stanza_dir in
+      let* scope = Scope.DB.find_by_dir stanza_dir in
+      Melange_rules.setup_emit_js_rules ~dir_contents ~dir:stanza_dir ~scope
+        ~sctx stanza)
 
 let gen_melange_emit_rules sctx ~dir ({ stanza_dir; stanza } as for_melange) =
   match
@@ -457,56 +458,64 @@ let gen_melange_emit_rules sctx ~dir ({ stanza_dir; stanza } as for_melange) =
                (Path.Source.to_string parent_melange_emit_dir)
            ]))
 
-let empty_rules =
+let rules_for ~dir ~allowed_subdirs rules =
   { Build_config.Rules.build_dir_only_sub_dirs =
-      Subdir_set.These (String.Set.of_keys automatic_sub_dirs_map)
+      Build_config.Rules.Build_only_sub_dirs.singleton ~dir
+        (Subdir_set.These allowed_subdirs)
   ; directory_targets = Path.Build.Map.empty
-  ; rules = Memo.return Rules.empty
+  ; rules
   }
 
-let gen_melange_emit_rules_or_empty_redirect sctx ~dir = function
-  | None -> Memo.return Build_config.(Redirect_to_parent empty_rules)
+let gen_melange_emit_rules_or_empty_redirect sctx ~dir ~allowed_subdirs
+    under_melange_emit =
+  let rules_for = rules_for ~dir ~allowed_subdirs in
+  match under_melange_emit with
+  | None ->
+    Memo.return
+      (Build_config.Redirect_to_parent (rules_for (Memo.return Rules.empty)))
   | Some for_melange -> (
     let+ melange_rules = gen_melange_emit_rules sctx ~dir for_melange in
     match melange_rules with
-    | Some r -> Build_config.Redirect_to_parent r
-    | None -> Build_config.(Redirect_to_parent empty_rules))
+    | Some r -> Build_config.Redirect_to_parent (rules_for r)
+    | None ->
+      Build_config.Redirect_to_parent (rules_for (Memo.return Rules.empty)))
 
 (* Once [gen_rules] has decided what to do with the directory, it should end
    with [has_rules] or [redirect_to_parent] *)
 let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t =
   let module S = Subdir_set in
   match components with
   | [ ".dune"; "ccomp" ] ->
-    has_rules S.empty (fun () ->
+    has_rules ~dir S.empty (fun () ->
         (* Add rules for C compiler detection *)
         Cxx_rules.rules ~sctx ~dir)
   | [ ".dune" ] ->
-    has_rules
+    has_rules ~dir
       (S.These (String.Set.of_list [ "ccomp" ]))
       (fun () -> Context.gen_configurator_rules (Super_context.context sctx))
   | ".js" :: rest ->
-    has_rules
+    has_rules ~dir
       (match rest with
       | [] -> S.All
       | _ -> S.empty)
       (fun () -> Jsoo_rules.setup_separate_compilation_rules sctx rest)
   | "_doc" :: rest -> Odoc.gen_rules sctx rest ~dir
   | ".topmod" :: comps ->
-    has_rules
+    has_rules ~dir
       (match comps with
       | [] -> S.All
       | _ -> S.empty)
       (fun () -> Top_module.gen_rules sctx ~dir ~comps)
   | ".ppx" :: rest ->
-    has_rules
+    has_rules ~dir
       (match rest with
       | [] -> S.All
       | _ -> S.empty)
       (fun () -> Preprocessing.gen_rules sctx rest)
   | _ -> (
     let* under_melange_emit_target = under_melange_emit_target ~dir in
     let src_dir = Path.Build.drop_build_context_exn dir in
+    let automatic_subdirs = automatic_subdirs components in
     Source_tree.find_dir src_dir >>= function
     | None -> (
       (* There is always a source dir at the root, so we can't be at the root if
@@ -515,24 +524,24 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t =
       Source_tree.find_dir parent >>= function
       | None ->
         gen_melange_emit_rules_or_empty_redirect sctx ~dir
-          under_melange_emit_target
+          ~allowed_subdirs:automatic_subdirs under_melange_emit_target
       | Some _ -> (
         match
           String.Map.find automatic_sub_dirs_map (Path.Source.basename src_dir)
         with
         | Some kind ->
-          has_rules Subdir_set.empty (fun () ->
+          has_rules ~dir Subdir_set.empty (fun () ->
               gen_rules_for_automatic_sub_dir ~sctx ~dir kind)
         | None ->
           gen_melange_emit_rules_or_empty_redirect sctx ~dir
-            under_melange_emit_target))
+            ~allowed_subdirs:automatic_subdirs under_melange_emit_target))
     | Some source_dir -> (
       (* This interprets "rule" and "copy_files" stanzas. *)
       Dir_contents.triage sctx ~dir
       >>= function
       | Group_part _ ->
         gen_melange_emit_rules_or_empty_redirect sctx ~dir
-          under_melange_emit_target
+          ~allowed_subdirs:automatic_subdirs under_melange_emit_target
       | Standalone_or_root { directory_targets; contents } -> (
         let rules =
           let* () = Memo.Lazy.force Context.force_configurator_files in
@@ -565,17 +574,9 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t =
         let* directory_targets =
           collect_directory_targets ~dir ~init:directory_targets
         in
-        let automatic_subdirs =
-          match List.last components with
-          | None -> String.Set.of_keys automatic_sub_dirs_map
-          | Some comp ->
-            if String.Map.mem automatic_sub_dirs_map comp then String.Set.empty
-            else String.Set.of_keys automatic_sub_dirs_map
-        in
         let build_config subdirs =
-          { Build_config.Rules.build_dir_only_sub_dirs = subdirs
-          ; directory_targets
-          ; rules
+          { (rules_for ~dir ~allowed_subdirs:subdirs rules) with
+            directory_targets
           }
         in
         match under_melange_emit_target with
@@ -599,15 +600,16 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t =
                    [ ".js"; "_doc"; ".ppx"; ".dune"; ".topmod" ])
             | _ -> subdirs
           in
-          Build_config.Rules (build_config (S.These subdirs))
+          Build_config.Rules (build_config subdirs)
         | Some for_melange -> (
-          let build_config = build_config (S.These automatic_subdirs) in
+          let build_config = build_config automatic_subdirs in
           let+ melange_rules = gen_melange_emit_rules sctx ~dir for_melange in
           match melange_rules with
           | None -> Build_config.Redirect_to_parent build_config
           | Some emit ->
             Build_config.Rules
-              (Build_config.Rules.combine_exn build_config emit)))))
+              (Build_config.Rules.combine_exn build_config
+                 (rules_for ~dir ~allowed_subdirs:automatic_subdirs emit))))))
 
 let with_context ctx ~f =
   Super_context.find ctx >>= function
@@ -621,7 +623,8 @@ let gen_rules ctx_or_install ~dir components =
         let+ subdirs, rules = Install_rules.symlink_rules sctx ~dir in
         let directory_targets = Rules.directory_targets rules in
         Build_config.Rules
-          { build_dir_only_sub_dirs = subdirs
+          { build_dir_only_sub_dirs =
+              Build_config.Rules.Build_only_sub_dirs.singleton ~dir subdirs
           ; directory_targets
           ; rules = Memo.return rules
           })

src/dune_rules/odoc.ml

@@ -801,7 +801,10 @@ let has_rules ?(directory_targets = Path.Build.Map.empty) m =
   let rules = Rules.collect_unit (fun () -> m) in
   Memo.return
     (Build_config.Rules
-       { rules; build_dir_only_sub_dirs = Subdir_set.empty; directory_targets })
+       { rules
+       ; build_dir_only_sub_dirs = Build_config.Rules.Build_only_sub_dirs.empty
+       ; directory_targets
+       })
 
 let with_package pkg ~f =
   let pkg = Package.Name.of_string pkg in
@@ -812,17 +815,20 @@ let with_package pkg ~f =
     Memo.return
       (Build_config.Rules
          { rules = Memo.return Rules.empty
-         ; build_dir_only_sub_dirs = Subdir_set.empty
+         ; build_dir_only_sub_dirs =
+             Build_config.Rules.Build_only_sub_dirs.empty
          ; directory_targets = Path.Build.Map.empty
          })
 
-let gen_rules sctx ~dir:_ rest =
+let gen_rules sctx ~dir rest =
   match rest with
   | [] ->
     Memo.return
       (Build_config.Rules
          { rules = Memo.return Rules.empty
-         ; build_dir_only_sub_dirs = Subdir_set.All
+         ; build_dir_only_sub_dirs =
+             Build_config.Rules.Build_only_sub_dirs.singleton ~dir
+               Subdir_set.All
          ; directory_targets = Path.Build.Map.empty
          })
   | [ "_html" ] ->

test/blackbox-tests/test-cases/formatting/load-automatic-dirs.t

@@ -0,0 +1,19 @@
+
+  $ touch .ocamlformat
+  $ cat > dune-project << EOF
+  > (lang dune 3.7)
+  > EOF
+  $ mkdir bin
+  $ cat > bin/ocaml_file.ml << EOF
+  > let  y=()
+  > EOF
+  $ cat > dune << EOF
+  > (include_subdirs unqualified)
+  > (library (name lib_reason))
+  > EOF
+  $ dune build ./bin/.formatted/ocaml_file.ml
+
+.formatted dir is loaded
+
+  $ ls _build/default/bin/.formatted
+  ocaml_file.ml