Add all dependency source dirs to Merlin's configuration.

Use new BH / SH directives Make specific tests for OCaml 5.2 Signed-off-by: Ulysse Gérard <[email protected]>
ocaml · Jul 1, 2024 · bcccf15 · bcccf15
1 parent f3319e2
commit bcccf15
Show file tree

Hide file tree

Showing 17 changed files with 195 additions and 49 deletions.
diff --git a/otherlibs/stdune/src/stdune.ml b/otherlibs/stdune/src/stdune.ml
@@ -1,5 +1,4 @@
-[@@@alert unstable "The API of this library is not stable and may change without notice."]
-[@@@alert "-unstable"]
+
 
 module Appendable_list = Appendable_list
 module Nonempty_list = Nonempty_list

diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml
@@ -182,7 +182,7 @@ let executables_rules
   let lib_config = ocaml.lib_config in
   let stdlib_dir = lib_config.stdlib_dir in
   let* requires_compile = Compilation_context.requires_compile cctx in
-  let* requires_link = Compilation_context.requires_link cctx in
+  let* requires_hidden = Compilation_context.requires_hidden cctx in
   let* dep_graphs =
     (* Building an archive for foreign stubs, we link the corresponding object
        files directly to improve perf. *)
@@ -266,7 +266,8 @@ let executables_rules
   in
   ( cctx
   , Merlin.make
-      ~requires:requires_link
+      ~requires_compile
+      ~requires_hidden
       ~stdlib_dir
       ~flags
       ~modules

diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml
@@ -579,7 +579,7 @@ let library_rules
   let scope = Compilation_context.scope cctx in
   let* requires_compile = Compilation_context.requires_compile cctx in
   let ocaml = Compilation_context.ocaml cctx in
-  let* requires_link = Compilation_context.requires_link cctx in
+  let* requires_hidden = Compilation_context.requires_hidden cctx in
   let stdlib_dir = ocaml.lib_config.stdlib_dir in
   let top_sorted_modules =
     let impl_only = Modules.With_vlib.impl_only modules in
@@ -635,7 +635,8 @@ let library_rules
   in
   ( cctx
   , Merlin.make
-      ~requires:requires_link
+      ~requires_compile
+      ~requires_hidden
       ~stdlib_dir
       ~flags
       ~modules

diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml
@@ -326,6 +326,7 @@ let setup_emit_cmj_rules
     in
     let* () = Module_compilation.build_all cctx in
     let* requires_compile = Compilation_context.requires_compile cctx in
+    let* requires_hidden = Compilation_context.requires_hidden cctx in
     let stdlib_dir = (Compilation_context.ocaml cctx).lib_config.stdlib_dir in
     let+ () =
       let emit_and_libs_deps =
@@ -354,7 +355,8 @@ let setup_emit_cmj_rules
     in
     ( cctx
     , Merlin.make
-        ~requires:requires_compile
+        ~requires_compile
+        ~requires_hidden
         ~stdlib_dir
         ~flags
         ~modules

diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml
@@ -51,20 +51,33 @@ module Processed = struct
     ; source_root : Path.t
     ; obj_dirs : Path.Set.t
     ; src_dirs : Path.Set.t
+    ; hidden_obj_dirs : Path.Set.t
+    ; hidden_src_dirs : Path.Set.t
     ; flags : string list
     ; extensions : string option Ml_kind.Dict.t list
     ; indexes : Path.t list
     }
 
   let dyn_of_config
-    { stdlib_dir; source_root; obj_dirs; src_dirs; flags; extensions; indexes }
+    { stdlib_dir
+    ; source_root
+    ; obj_dirs
+    ; src_dirs
+    ; hidden_obj_dirs
+    ; hidden_src_dirs
+    ; flags
+    ; extensions
+    ; indexes
+    }
     =
     let open Dyn in
     record
       [ "stdlib_dir", option Path.to_dyn stdlib_dir
       ; "source_root", Path.to_dyn source_root
       ; "obj_dirs", Path.Set.to_dyn obj_dirs
       ; "src_dirs", Path.Set.to_dyn src_dirs
+      ; "hidden_obj_dirs", Path.Set.to_dyn hidden_obj_dirs
+      ; "hidden_src_dirs", Path.Set.to_dyn hidden_src_dirs
       ; "flags", list string flags
       ; "extensions", list (Ml_kind.Dict.to_dyn (Dyn.option string)) extensions
       ; "indexes", list Path.to_dyn indexes
@@ -115,6 +128,8 @@ module Processed = struct
           ; source_root = Path.Source.root |> Path.source
           ; obj_dirs = Path.Set.empty
           ; src_dirs = Path.Set.empty
+          ; hidden_obj_dirs = Path.Set.empty
+          ; hidden_src_dirs = Path.Set.empty
           ; flags = [ "-x" ]
           ; extensions = [ { Ml_kind.Dict.intf = None; impl = Some "ext" } ]
           ; indexes = []
@@ -162,7 +177,16 @@ module Processed = struct
     ~opens
     ~pp
     ~reader
-    { stdlib_dir; source_root; obj_dirs; src_dirs; flags; extensions; indexes }
+    { stdlib_dir
+    ; source_root
+    ; obj_dirs
+    ; src_dirs
+    ; hidden_obj_dirs
+    ; hidden_src_dirs
+    ; flags
+    ; extensions
+    ; indexes
+    }
     =
     let make_directive tag value = Sexp.List [ Atom tag; value ] in
     let make_directive_of_path tag path =
@@ -178,6 +202,12 @@ module Processed = struct
     let exclude_query_dir = [ Sexp.List [ Atom "EXCLUDE_QUERY_DIR" ] ] in
     let obj_dirs = Path.Set.to_list_map obj_dirs ~f:(make_directive_of_path "B") in
     let src_dirs = Path.Set.to_list_map src_dirs ~f:(make_directive_of_path "S") in
+    let hidden_obj_dirs =
+      Path.Set.to_list_map hidden_obj_dirs ~f:(make_directive_of_path "BH")
+    in
+    let hidden_src_dirs =
+      Path.Set.to_list_map hidden_src_dirs ~f:(make_directive_of_path "SH")
+    in
     let flags =
       let flags =
         match flags with
@@ -222,6 +252,8 @@ module Processed = struct
          ; exclude_query_dir
          ; obj_dirs
          ; src_dirs
+         ; hidden_obj_dirs
+         ; hidden_src_dirs
          ; flags
          ; unit_name
          ; suffixes
@@ -249,6 +281,8 @@ module Processed = struct
     flags
     obj_dirs
     src_dirs
+    hidden_obj_dirs
+    hidden_src_dirs
     extensions
     indexes
     =
@@ -261,6 +295,8 @@ module Processed = struct
     printf "SOURCE_ROOT %s\n" (serialize_path source_root);
     Path.Set.iter obj_dirs ~f:(fun p -> printf "B %s\n" (serialize_path p));
     Path.Set.iter src_dirs ~f:(fun p -> printf "S %s\n" (serialize_path p));
+    Path.Set.iter hidden_obj_dirs ~f:(fun p -> printf "BH %s\n" (serialize_path p));
+    Path.Set.iter hidden_src_dirs ~f:(fun p -> printf "SH %s\n" (serialize_path p));
     List.iter indexes ~f:(fun p -> printf "INDEX %s\n" (serialize_path p));
     List.iter extensions ~f:(fun x ->
       Option.iter (get_ext x) ~f:(fun (impl, intf) ->
@@ -335,27 +371,46 @@ module Processed = struct
     | Error msg -> Printf.eprintf "%s\n" msg
     | Ok [] -> Printf.eprintf "No merlin configuration found.\n"
     | Ok (init :: tl) ->
-      let pp_configs, obj_dirs, src_dirs, flags, extensions, indexes =
+      let ( pp_configs
+          , obj_dirs
+          , src_dirs
+          , hidden_obj_dirs
+          , hidden_src_dirs
+          , flags
+          , extensions
+          , indexes )
+        =
         (* We merge what is easy to merge and ignore the rest *)
         List.fold_left
           tl
           ~init:
             ( [ init.pp_config ]
             , init.config.obj_dirs
             , init.config.src_dirs
+            , init.config.hidden_obj_dirs
+            , init.config.hidden_src_dirs
             , [ init.config.flags ]
             , init.config.extensions
             , init.config.indexes )
           ~f:
             (fun
-              (acc_pp, acc_obj, acc_src, acc_flags, acc_ext, acc_indexes)
+              ( acc_pp
+              , acc_obj
+              , acc_src
+              , acc_hidden_obj
+              , acc_hidden_src
+              , acc_flags
+              , acc_ext
+              , acc_indexes )
               { per_file_config = _
               ; pp_config
               ; config =
                   { stdlib_dir = _
                   ; source_root = _
                   ; obj_dirs
                   ; src_dirs
+                  ; hidden_obj_dirs
+                  ; hidden_src_dirs
                   ; flags
                   ; extensions
                   ; indexes
@@ -365,6 +420,8 @@ module Processed = struct
             ( pp_config :: acc_pp
             , Path.Set.union acc_obj obj_dirs
             , Path.Set.union acc_src src_dirs
+            , Path.Set.union acc_hidden_obj hidden_obj_dirs
+            , Path.Set.union acc_hidden_src hidden_src_dirs
             , flags :: acc_flags
             , extensions @ acc_ext
             , indexes @ acc_indexes ))
@@ -378,6 +435,8 @@ module Processed = struct
            flags
            obj_dirs
            src_dirs
+           hidden_obj_dirs
+           hidden_src_dirs
            extensions
            indexes)
   ;;
@@ -399,7 +458,8 @@ module Unprocessed = struct
      Processed.t] *)
   type config =
     { stdlib_dir : Path.t
-    ; requires : Lib.Set.t
+    ; requires_compile : Lib.t list Resolve.t
+    ; requires_hidden : Lib.t list Resolve.t
     ; flags : string list Action_builder.t
     ; preprocess :
         Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t
@@ -418,7 +478,8 @@ module Unprocessed = struct
     }
 
   let make
-    ~requires
+    ~requires_compile
+    ~requires_hidden
     ~stdlib_dir
     ~flags
     ~preprocess
@@ -437,11 +498,6 @@ module Unprocessed = struct
       | `Melange_emit -> Melange
       | `Lib (m : Lib_mode.Map.Set.t) -> Lib_mode.Map.Set.for_merlin m
     in
-    let requires =
-      match Resolve.peek requires with
-      | Ok l -> Lib.Set.of_list l
-      | Error () -> Lib.Set.empty
-    in
     let objs_dirs =
       Path.Set.singleton @@ obj_dir_of_lib `Private mode (Obj_dir.of_local obj_dir)
     in
@@ -450,7 +506,8 @@ module Unprocessed = struct
     let config =
       { stdlib_dir
       ; mode
-      ; requires
+      ; requires_compile
+      ; requires_hidden
       ; flags
       ; preprocess
       ; libname
@@ -556,6 +613,21 @@ module Unprocessed = struct
       ~f:(pp_flags ctx ~expander t.config.libname)
   ;;
 
+  let add_lib_dirs sctx mode ~init libs =
+    Action_builder.of_memo
+      (let open Memo.O in
+       Memo.parallel_map libs ~f:(fun lib ->
+         let+ dirs = src_dirs sctx lib in
+         lib, dirs)
+       >>| List.fold_left ~init ~f:(fun (src_dirs, obj_dirs) (lib, more_src_dirs) ->
+         ( Path.Set.union src_dirs more_src_dirs
+         , let public_cmi_dir =
+             let info = Lib.info lib in
+             obj_dir_of_lib `Public mode (Lib_info.obj_dir info)
+           in
+           Path.Set.add obj_dirs public_cmi_dir )))
+  ;;
+
   let process
     ({ modules
      ; ident = _
@@ -566,7 +638,8 @@ module Unprocessed = struct
          ; flags
          ; objs_dirs
          ; source_dirs
-         ; requires
+         ; requires_compile
+         ; requires_hidden
          ; preprocess = _
          ; libname = _
          ; mode
@@ -591,9 +664,11 @@ module Unprocessed = struct
            | [] -> None
            | stdlib_dir :: _ -> Some stdlib_dir)
       in
-      let* requires =
+      let* requires_compile = Resolve.read requires_compile in
+      let* requires_hidden = Resolve.read requires_hidden in
+      let* requires_compile, requires_hidden =
         match t.config.mode with
-        | Ocaml _ -> Action_builder.return requires
+        | Ocaml _ -> Action_builder.return (requires_compile, requires_hidden)
         | Melange ->
           Action_builder.of_memo
             (let open Memo.O in
@@ -612,26 +687,17 @@ module Unprocessed = struct
                  | Ok libs -> libs
                  | Error _ -> []
                in
-               Lib.Set.union requires (Lib.Set.of_list libs)
-             | None -> Memo.return requires)
+               List.concat [ requires_compile; libs ], requires_hidden
+             | None -> Memo.return (requires_compile, requires_hidden))
       in
       let+ flags = flags
+      and+ indexes = Action_builder.of_memo (Ocaml_index.context_indexes sctx)
       and+ src_dirs, obj_dirs =
-        Action_builder.of_memo
-          (let open Memo.O in
-           Memo.parallel_map (Lib.Set.to_list requires) ~f:(fun lib ->
-             let+ dirs = src_dirs sctx lib in
-             lib, dirs)
-           >>| List.fold_left
-                 ~init:(Path.set_of_source_paths source_dirs, objs_dirs)
-                 ~f:(fun (src_dirs, obj_dirs) (lib, more_src_dirs) ->
-                   ( Path.Set.union src_dirs more_src_dirs
-                   , let public_cmi_dir =
-                       let info = Lib.info lib in
-                       obj_dir_of_lib `Public mode (Lib_info.obj_dir info)
-                     in
-                     Path.Set.add obj_dirs public_cmi_dir )))
-      and+ indexes = Action_builder.of_memo (Ocaml_index.context_indexes sctx) in
+        let init = Path.set_of_source_paths source_dirs, objs_dirs in
+        add_lib_dirs sctx mode ~init requires_compile
+      and+ hidden_src_dirs, hidden_obj_dirs =
+        add_lib_dirs sctx mode ~init:(Path.Set.empty, Path.Set.empty) requires_hidden
+      in
       let src_dirs =
         Path.Set.union src_dirs (Path.Set.of_list_map ~f:Path.source more_src_dirs)
       in
@@ -640,6 +706,8 @@ module Unprocessed = struct
       ; source_root
       ; src_dirs
       ; obj_dirs
+      ; hidden_src_dirs
+      ; hidden_obj_dirs
       ; flags
       ; extensions
       ; indexes

diff --git a/src/dune_rules/merlin/merlin.mli b/src/dune_rules/merlin/merlin.mli
@@ -41,7 +41,8 @@ module Processed : sig
 end
 
 val make
-  :  requires:Lib.t list Resolve.t
+  :  requires_compile:Lib.t list Resolve.t
+  -> requires_hidden:Lib.t list Resolve.t
   -> stdlib_dir:Path.t
   -> flags:Ocaml_flags.t
   -> preprocess:Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t

diff --git a/test/blackbox-tests/test-cases/merlin/dune b/test/blackbox-tests/test-cases/merlin/dune
@@ -9,3 +9,11 @@
 (cram
  (applies_to github4125)
  (deps %{bin:opam}))
+
+(cram
+ (applies_to implicit-transitive-deps)
+ (enabled_if (< %{ocaml_version} 5.2)))
+
+(cram
+ (applies_to implicit-transitive-deps-5.2)
+ (enabled_if (>= %{ocaml_version} 5.2)))
diff --git a/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/bin/dune b/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/bin/dune
@@ -0,0 +1,4 @@
+(executable
+ (name main)
+ (flags :standard -w -34)
+ (libraries lib1))
diff --git a/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/bin/main.ml b/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/bin/main.ml
@@ -0,0 +1 @@
+type t = Lib1.t
diff --git a/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/dune-project b/test/blackbox-tests/test-cases/merlin/implicit-transitive-deps-5.2.t/dune-project
@@ -0,0 +1,2 @@
+(lang dune 3.17)
+(implicit_transitive_deps false)