ocaml · rgrinberg · Feb 2, 2024 · Jan 31, 2024
diff --git a/bin/describe/describe_external_lib_deps.ml b/bin/describe/describe_external_lib_deps.ml
@@ -139,12 +139,9 @@ let exes_extensions (lib_config : Dune_rules.Lib_config.t) modes =
       ~ext_dll:lib_config.ext_dll)
 ;;
 
-let libs db (context : Context.t) (build_system : Dune_rules.Main.build_system) =
-  let { Dune_rules.Main.conf; contexts = _; _ } = build_system in
+let libs db (context : Context.t) =
   let open Memo.O in
-  let* dune_files =
-    Dune_rules.Dune_load.dune_files conf ~context:(Context.name context)
-  in
+  let* dune_files = Context.name context |> Dune_rules.Dune_load.dune_files in
   Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_rules.Dune_file.t) ->
     Dune_file.stanzas dune_file
     |> Memo.parallel_map ~f:(fun stanza ->
@@ -190,11 +187,11 @@ let libs db (context : Context.t) (build_system : Dune_rules.Main.build_system)
   >>| List.concat
 ;;
 
-let external_resolved_libs setup (context : Context.t) =
+let external_resolved_libs (context : Context.t) =
   let open Memo.O in
   let* scope = Dune_rules.Scope.DB.find_by_dir (Context.build_dir context) in
   let db = Dune_rules.Scope.libs scope in
-  libs db context setup
+  libs db context
   >>| List.filter ~f:(fun (x : Item.t) ->
     not (List.is_empty x.external_deps && List.is_empty x.internal_deps))
 ;;
@@ -224,7 +221,7 @@ let term =
     |> Context.name
     |> Dune_engine.Context_name.to_string
   in
-  external_resolved_libs setup (Super_context.context super_context)
+  external_resolved_libs (Super_context.context super_context)
   >>| to_dyn context_name
   >>| Describe_format.print_dyn format
 ;;

diff --git a/bin/describe/describe_pp.ml b/bin/describe/describe_pp.ml
@@ -56,7 +56,7 @@ let get_pped_file super_context file =
          >>| Source_tree.Dir.path
          >>| Path.source
        in
-       let* dune_file = Dune_rules.Only_packages.stanzas_in_dir (dir |> in_build_dir) in
+       let* dune_file = Dune_rules.Dune_load.stanzas_in_dir (dir |> in_build_dir) in
        let staged_pps =
          Option.bind dune_file ~f:(fun dune_file ->
            Dune_file.find_stanzas dune_file Dune_rules.Library.key

diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml
@@ -518,7 +518,7 @@ module Crawl = struct
   (* Builds a workspace description for the provided dune setup and context *)
   let workspace
     options
-    ({ Dune_rules.Main.conf; contexts = _; scontexts } : Dune_rules.Main.build_system)
+    ({ Dune_rules.Main.contexts = _; scontexts } : Dune_rules.Main.build_system)
     (context : Context.t)
     dirs
     : Descr.Workspace.t Memo.t
@@ -527,8 +527,7 @@ module Crawl = struct
     let sctx = Context_name.Map.find_exn scontexts context_name in
     let open Memo.O in
     let* dune_files =
-      Dune_load.dune_files conf ~context:context_name
-      >>| List.filter ~f:(dune_file_is_in_dirs dirs)
+      Dune_load.dune_files context_name >>| List.filter ~f:(dune_file_is_in_dirs dirs)
     in
     let* exes, exe_libs =
       (* the list of workspace items that describe executables, and the list of
@@ -556,8 +555,8 @@ module Crawl = struct
     in
     let* project_libs =
       (* the list of libraries declared in the project *)
-      Dune_load.projects conf
-      |> Memo.parallel_map ~f:(fun project ->
+      Dune_load.projects ()
+      >>= Memo.parallel_map ~f:(fun project ->
         Scope.DB.find_by_project context project >>| Scope.libs >>= Lib.DB.all)
       >>| Lib.Set.union_all
       >>| Lib.Set.filter ~f:(lib_is_in_dirs dirs)

diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml
@@ -81,7 +81,7 @@ module Workspace = struct
   let get () =
     let open Memo.O in
     Memo.run
-      (let+ packages = Dune_rules.Dune_load.load () >>| Dune_rules.Dune_load.packages
+      (let+ packages = Dune_rules.Dune_load.packages ()
        and+ contexts = Context.DB.all () in
        { packages; contexts })
   ;;

diff --git a/bin/pkg/pkg_common.ml b/bin/pkg/pkg_common.ml
@@ -98,9 +98,7 @@ let get_repos repos ~repositories =
 
 let find_local_packages =
   let open Memo.O in
-  Dune_rules.Dune_load.load ()
-  >>| Dune_rules.Dune_load.packages
-  >>| Package.Name.Map.map ~f:Package.to_local_package
+  Dune_rules.Dune_load.packages () >>| Package.Name.Map.map ~f:Package.to_local_package
 ;;
 
 let pp_packages packages =

diff --git a/bin/subst.ml b/bin/subst.ml
@@ -359,7 +359,7 @@ let subst vcs =
       | Some n -> n.loc_of_arg, n.arg
     in
     let package_named_after_project =
-      let packages = Dune_project.packages dune_project.project in
+      let packages = Dune_project.including_hidden_packages dune_project.project in
       Package.Name.Map.find packages name
     in
     let metadata_from_dune_project () = Dune_project.info dune_project.project in

diff --git a/doc/changes/9879.md b/doc/changes/9879.md
@@ -0,0 +1,2 @@
+- Fix `$ dune install -p` incorrectly recognizing packages that are supposed to
+  be filtered (#9879, fixes #4814, @rgrinberg)
diff --git a/src/dune_rules/alias_rec.ml b/src/dune_rules/alias_rec.ml
@@ -44,7 +44,7 @@ include Alias_builder.Alias_rec (struct
             =
             f ~path:build_path
           and* stanzas_in_dir =
-            Action_builder.of_memo (Only_packages.stanzas_in_dir build_path)
+            Action_builder.of_memo (Dune_load.stanzas_in_dir build_path)
           in
           match stanzas_in_dir with
           | None -> Action_builder.return found_in_source

diff --git a/src/dune_rules/artifacts_db.ml b/src/dune_rules/artifacts_db.ml
@@ -103,8 +103,7 @@ let all =
     let artifacts =
       let local_bins =
         Memo.lazy_ ~name:"get_installed_binaries" (fun () ->
-          let* stanzas = Only_packages.filtered_stanzas (Context.name context) in
-          get_installed_binaries ~context stanzas)
+          Context.name context |> Dune_load.dune_files >>= get_installed_binaries ~context)
       in
       Artifacts.create context ~local_bins |> Memo.return
     in

diff --git a/src/dune_rules/cram/cram_rules.ml b/src/dune_rules/cram/cram_rules.ml
@@ -99,7 +99,7 @@ let test_rule
 
 let collect_stanzas =
   let stanzas dir ~f =
-    let+ stanzas = Only_packages.stanzas_in_dir dir in
+    let+ stanzas = Dune_load.stanzas_in_dir dir in
     match stanzas with
     | None -> []
     | Some (d : Dune_file.t) ->
@@ -128,7 +128,7 @@ let rules ~sctx ~expander ~dir tests =
   let open Memo.O in
   let* stanzas = collect_stanzas ~dir
   and* with_package_mask =
-    Only_packages.get_mask ()
+    Dune_load.mask ()
     >>| function
     | None -> fun _packages f -> f ()
     | Some only ->

diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml
@@ -232,7 +232,7 @@ end = struct
        | tr
F438
ue -> Memo.return Lock_dir
        | false ->
          let build_dir_is_project_root = build_dir_is_project_root st_dir in
-         Only_packages.stanzas_in_dir dir
+         Dune_load.stanzas_in_dir dir
          >>= (function
           | Some d -> has_dune_file ~dir st_dir ~build_dir_is_project_root d
           | None ->

diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml
@@ -8,7 +8,6 @@ type t =
 
 let dir t = t.dir
 let stanzas t = t.stanzas
-let set_stanzas t stanzas = { t with stanzas }
 let project t = t.project
 
 let is_promoted_rule =
@@ -289,11 +288,7 @@ module Script = struct
     in
     let* () =
       let* env = Context.host context >>| Context.installed_env in
-      let ocaml =
-        (* CR-rgrinberg: This ocaml seems wrong. shouldn't we be using the
-           host context here? *)
-        Action.Prog.ok_exn ocaml.ocaml
-      in
+      let ocaml = Action.Prog.ok_exn ocaml.ocaml in
       let args =
         [ "-I"; "+compiler-libs"; Path.to_absolute_filename (Path.build wrapper) ]
       in
@@ -329,6 +324,35 @@ module Script = struct
   ;;
 end
 
+let filter_out_stanzas_from_hidden_packages ~visible_pkgs =
+  List.filter_map ~f:(fun stanza ->
+    let include_stanza =
+      match Stanzas.stanza_package stanza with
+      | None -> true
+      | Some package ->
+        let name = Package.name package in
+        Package.Name.Map.mem visible_pkgs name
+    in
+    if include_stanza
+    then Some stanza
+    else (
+      match Stanza.repr stanza with
+      | Library.T l ->
+        Library_redirect.Local.of_private_lib l
+        |> Option.map ~f:Library_redirect.Local.make_stanza
+      | _ -> None))
+;;
+
+let filter_stanzas (mask : Only_packages.t) (dune_files : t list) =
+  match mask with
+  | None -> dune_files
+  | Some visible_pkgs ->
+    List.map dune_files ~f:(fun dune_file ->
+      { dune_file with
+        stanzas = filter_out_stanzas_from_hidden_packages ~visible_pkgs dune_file.stanzas
+      })
+;;
+
 module Eval = struct
   type nonrec t =
     | Literal of t
@@ -357,7 +381,9 @@ module Eval = struct
       Literal stanzas
   ;;
 
-  let eval dune_files =
+  let eval dune_files (mask : Only_packages.t) =
+    (* CR-rgrinberg: all this evaluation complexity is to share
+       some work in multi context builds. Is it worth it? *)
     let+ static, dynamic =
       Appendable_list.to_list dune_files
       |> Memo.parallel_map ~f:(fun (dir, project, dune_file) ->
@@ -366,9 +392,10 @@ module Eval = struct
         | Literal x -> Left x
         | Script s -> Right s)
     in
-    Staged.stage (fun context ->
+    let static = filter_stanzas mask static in
+    fun context ->
       let+ dynamic = Memo.parallel_map dynamic ~f:(Script.eval_one ~context) in
-      static @ dynamic)
+      static @ filter_stanzas mask dynamic
   ;;
 end
 

diff --git a/src/dune_rules/dune_file.mli b/src/dune_rules/dune_file.mli
@@ -7,7 +7,6 @@ type t
 
 val dir : t -> Path.Source.t
 val stanzas : t -> Stanza.t list
-val set_stanzas : t -> Stanza.t list -> t
 val project : t -> Dune_project.t
 val equal : t -> t -> bool
 val hash : t -> int
@@ -17,7 +16,8 @@ val fold_stanzas : t list -> init:'acc -> f:(t -> Stanza.t -> 'acc -> 'acc) -> '
 
 val eval
   :  (Path.Source.t * Dune_project.t * Dune_file0.t) Appendable_list.t
-  -> (Context_name.t -> t list Memo.t) Staged.t Memo.t
+  -> Only_packages.t
+  -> t list Per_context.t Memo.t
 
 module Memo_fold : sig
   val fold_stanzas
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		- Fix `$ dune install -p` incorrectly recognizing packages that are supposed to
		be filtered (#9879, fixes #4814, @rgrinberg)