From 20ad5e109e3879a54e988fd4f9b2922c7a6d5fb9 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 16 Mar 2023 00:18:54 -0700 Subject: [PATCH] fix(rules): merge allowed subdirs correctly for Redirect_to_parent rules (#7207) * fix(rules): merge allowed subdirs correctly for Redirect_to_parent rules --- src/dune_engine/build_config.ml | 21 ++++- src/dune_engine/build_config.mli | 18 +++- src/dune_engine/load_rules.ml | 20 +++- src/dune_rules/gen_rules.ml | 91 ++++++++++--------- src/dune_rules/odoc.ml | 14 ++- .../formatting/load-automatic-dirs.t | 19 ++++ 6 files changed, 128 insertions(+), 55 deletions(-) create mode 100644 test/blackbox-tests/test-cases/formatting/load-automatic-dirs.t diff --git a/src/dune_engine/build_config.ml b/src/dune_engine/build_config.ml index dc208932a8f..3b6958a1248 100644 --- a/src/dune_engine/build_config.ml +++ b/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 = diff --git a/src/dune_engine/build_config.mli b/src/dune_engine/build_config.mli index 35e904cdda3..bc8537a922a 100644 --- a/src/dune_engine/build_config.mli +++ b/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]. *) diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index 013a5d04a0a..30feb3b33d0 100644 --- a/src/dune_engine/load_rules.ml +++ b/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 diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 4a513eb1f8e..e47c9988671 100644 --- a/src/dune_rules/gen_rules.ml +++ b/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,20 +458,27 @@ 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] *) @@ -478,28 +486,28 @@ 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) @@ -507,6 +515,7 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t = | _ -> ( 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 }) diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index d15d48a6bc0..93d3672358b 100644 --- a/src/dune_rules/odoc.ml +++ b/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" ] -> diff --git a/test/blackbox-tests/test-cases/formatting/load-automatic-dirs.t b/test/blackbox-tests/test-cases/formatting/load-automatic-dirs.t new file mode 100644 index 00000000000..718c1645e2e --- /dev/null +++ b/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