feature: enable (include_subdirs qualified)

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

ps-id: f0bdd789-87c5-4047-b418-47cdaf7749ae

CHANGES.md

@@ -43,6 +43,13 @@ Unreleased
 - Fix missing dependencies when detecting the kind of C compiler we're using
   (#6610, fixes #6415, @emillon)
 
+- Allow `(include_subdirs qualified)` for OCaml projects. (#6594, fixes #1084,
+  @rgrinberg)
+
+- Accurately determine merlin configuration for all sources selected with
+  `copy#` and `copy_files#`. The old heuristic of looking for a module in
+  parent directories is removed (#6594, @rgrinberg)
+
 3.6.0 (2022-11-14)
 ------------------
 

bin/describe.ml

@@ -262,7 +262,7 @@ module Crawl = struct
         Memo.return
         @@
         match Module.kind unit with
-        | Alias ->
+        | Alias _ ->
           (* TODO: handle Alias modules, that are generated by dune. They are
              currently associated to no ocamldep-related rules. *)
           Action_builder.return no_deps

bin/ocaml_merlin.ml

@@ -78,14 +78,13 @@ end = struct
   let load_merlin_file file =
     (* We search for an appropriate merlin configuration in the current
        directory and its parents *)
-    let filename = String.lowercase_ascii (Path.Build.basename file) in
     let rec find_closest path =
       match
         get_merlin_files_paths path
         |> List.find_map ~f:(fun file_path ->
                match Merlin.Processed.load_file file_path with
                | Error msg -> Some (Merlin_conf.make_error msg)
-               | Ok config -> Merlin.Processed.get config ~filename)
+               | Ok config -> Merlin.Processed.get config ~file)
       with
       | Some p -> Some p
       | None -> (

bin/top.ml

@@ -190,9 +190,7 @@ module Module = struct
       let+ (pp, ppx), files_to_load = Memo.fork_and_join pps files_to_load in
       let code =
         let modules = Dune_rules.Compilation_context.modules cctx in
-        let opens_ =
-          Dune_rules.Module_compilation.open_modules modules module_
-        in
+        let opens_ = Dune_rules.Modules.local_open modules module_ in
         List.map opens_ ~f:(fun name ->
             sprintf "open %s" (Dune_rules.Module_name.to_string name))
       in

src/dune_rules/action_unexpanded.ml

@@ -370,11 +370,12 @@ end = struct
   end
 end
 
-let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
+let rec expand (t : Dune_lang.Action.t) ~context : Action.t Action_expander.t =
   let module A = Action_expander in
   let module E = Action_expander.E in
   let open Action_expander.O in
   let module O (* [O] for "outcome" *) = Action in
+  let expand = expand ~context in
   let expand_run prog args =
     let+ args = A.all (List.map args ~f:E.strings)
     and+ prog, more_args = E.prog_and_args prog in
@@ -434,7 +435,7 @@ let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
   | Copy_and_add_line_directive (x, y) ->
     let+ x = E.dep x
     and+ y = E.target y in
-    Copy_line_directive.action x y
+    Copy_line_directive.action context ~src:x ~dst:y
   | System x ->
     let+ x = E.string x in
     O.System x
@@ -485,8 +486,9 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what =
     Expander.set_expanding_what expander (User_action_without_targets { what })
   in
   let* { Action_builder.With_targets.build; targets } =
+    let context = Expander.context expander in
     Action_builder.of_memo
-      (Action_expander.run (expand t) ~targets_dir:None ~expander)
+      (Action_expander.run (expand ~context t) ~targets_dir:None ~expander)
   in
   if not (Targets.is_empty targets) then
     User_error.raise ~loc
@@ -529,7 +531,9 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir
     Expander.set_expanding_what expander (User_action targets_written_by_user)
   in
   let+! { Action_builder.With_targets.build; targets } =
-    Action_expander.run (expand t) ~targets_dir:(Some targets_dir) ~expander
+    let context = Expander.context expander in
+    Action_expander.run (expand ~context t) ~targets_dir:(Some targets_dir)
+      ~expander
   in
   let targets =
     match (targets_written_by_user : _ Targets_spec.t) with

src/dune_rules/buildable_rules.ml

@@ -1,20 +1,21 @@
 open Import
 open Memo.O
 
-let gen_select_rules t ~dir compile_info =
+let gen_select_rules sctx ~dir compile_info =
   let open Memo.O in
   Lib.Compile.resolved_selects compile_info
   |> Resolve.Memo.read_memo
   >>= Memo.parallel_iter
         ~f:(fun { Lib.Compile.Resolved_select.dst_fn; src_fn } ->
           let dst = Path.Build.relative dir dst_fn in
-          Super_context.add_rule t ~dir
+          Super_context.add_rule sctx ~dir
             (Action_builder.with_file_targets ~file_targets:[ dst ]
                (let open Action_builder.O in
                let* src_fn = Resolve.read src_fn in
                let src = Path.build (Path.Build.relative dir src_fn) in
                let+ () = Action_builder.path src in
-               Action.Full.make (Copy_line_directive.action src dst))))
+               let context = Super_context.context sctx in
+               Action.Full.make (Copy_line_directive.action context ~src ~dst))))
 
 let with_lib_deps (t : Context.t) compile_info ~dir ~f =
   let prefix =

src/dune_rules/copy_line_directive.ml

@@ -1,54 +1,111 @@
 open Import
 
+module DB = struct
+  module Persistent = Dune_util.Persistent.Make (struct
+    type nonrec t = Path.Build.t Path.Build.Table.t
+
+    let name = "COPY-LINE-DIRECTIVE-MAP"
+
+    let version = 1
+
+    let to_dyn = Path.Build.Table.to_dyn Path.Build.to_dyn
+  end)
+
+  let needs_dumping = ref false
+
+  let file = Path.relative Path.build_dir ".copy-db"
+
+  let t =
+    (* This mutable table is safe: it's only observed by [$ dune ocaml merlin] *)
+    lazy
+      (match Persistent.load file with
+      | None -> Path.Build.Table.create 128
+      | Some t -> t)
+
+  let dump () =
+    if !needs_dumping && Path.build_dir_exists () then (
+      needs_dumping := false;
+      Persistent.dump file (Lazy.force t))
+
+  let () = at_exit dump
+
+  let rec follow_while path ~f =
+    let t = Lazy.force t in
+    match Path.Build.Table.find t path with
+    | None -> None
+    | Some p -> (
+      match f p with
+      | None -> follow_while p ~f
+      | Some p -> Some p)
+
+  let set ~src ~dst =
+    let t = Lazy.force t in
+    needs_dumping := true;
+    Path.Build.Table.set t src dst
+end
+
 let line_directive ~filename:fn ~line_number =
   let directive =
     if Foreign_language.has_foreign_extension ~fn then "line" else ""
   in
   sprintf "#%s %d %S\n" directive line_number fn
 
 module Spec = struct
-  type ('path, 'target) t = 'path * 'target
+  type merlin =
+    | Yes
+    | No
+
+  let bool_of_merlin = function
+    | Yes -> true
+    | No -> false
+
+  type ('path, 'target) t = 'path * 'target * merlin
 
   let name = "copy-line-directive"
 
   let version = 1
 
-  let bimap (src, dst) f g = (f src, g dst)
+  let bimap (src, dst, merlin) f g = (f src, g dst, merlin)
 
   let is_useful_to ~distribute:_ ~memoize = memoize
 
-  let encode (src, dst) path target : Dune_lang.t =
+  let encode (src, dst, merlin) path target : Dune_lang.t =
     List
       [ Dune_lang.atom_or_quoted_string "copy-line-directive"
       ; path src
       ; target dst
+      ; Dune_lang.atom_or_quoted_string (Bool.to_string (bool_of_merlin merlin))
       ]
 
-  let action (src, dst) ~ectx:_ ~eenv:_ =
+  let action (src, dst, merlin) ~ectx:_ ~eenv:_ =
     Io.with_file_in src ~f:(fun ic ->
         Path.build dst
         |> Io.with_file_out ~f:(fun oc ->
                let fn = Path.drop_optional_build_context_maybe_sandboxed src in
                output_string oc
                  (line_directive ~filename:(Path.to_string fn) ~line_number:1);
                Io.copy_channels ic oc));
+    (match merlin with
+    | No -> ()
+    | Yes ->
+      Path.as_in_build_dir src |> Option.iter ~f:(fun src -> DB.set ~src ~dst));
     Fiber.return ()
 end
 
-let action src dst =
+let action (context : Context.t) ~src ~dst =
   let module M = struct
     type path = Path.t
 
     type target = Path.Build.t
 
     module Spec = Spec
 
-    let v = (src, dst)
+    let v = (src, dst, if context.merlin then Spec.Yes else No)
   end in
   Action.Extension (module M)
 
-let builder ~src ~dst =
+let builder context ~src ~dst =
   let open Action_builder.O in
   Action_builder.with_file_targets ~file_targets:[ dst ]
     (Action_builder.path src
-    >>> Action_builder.return (Action.Full.make (action src dst)))
+    >>> Action_builder.return (Action.Full.make (action context ~src ~dst)))

src/dune_rules/copy_line_directive.mli

@@ -1,6 +1,13 @@
 open Import
 
-val action : Path.t -> Path.Build.t -> Action.t
+module DB : sig
+  val follow_while : Path.Build.t -> f:(Path.Build.t -> 'a option) -> 'a option
+end
+
+val action : Context.t -> src:Path.t -> dst:Path.Build.t -> Action.t
 
 val builder :
-  src:Path.t -> dst:Path.Build.t -> Action.Full.t Action_builder.With_targets.t
+     Context.t
+  -> src:Path.t
+  -> dst:Path.Build.t
+  -> Action.Full.t Action_builder.With_targets.t

src/dune_rules/dep_rules.ml

@@ -43,17 +43,23 @@ let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ }
   in
   read
 
-let deps_of_module md ~ml_kind m =
+let deps_of_module ({ modules; _ } as md) ~ml_kind m =
   match Module.kind m with
   | Wrapped_compat ->
-    let modules = md.modules in
     let interface_module =
       match Modules.lib_interface modules with
       | Some m -> m
       | None -> Modules.compat_for_exn modules m
     in
-    Action_builder.return (List.singleton interface_module) |> Memo.return
-  | _ -> Ocamldep.deps_of md ~ml_kind m
+    List.singleton interface_module |> Action_builder.return |> Memo.return
+  | _ -> (
+    let+ deps = Ocamldep.deps_of md ~ml_kind m in
+    match Modules.alias_for modules m with
+    | [] -> deps
+    | aliases ->
+      let open Action_builder.O in
+      let+ deps = deps in
+      aliases @ deps)
 
 let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m =
   let vimpl = Option.value_exn vimpl in
@@ -82,8 +88,11 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m =
 let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) =
   let is_alias =
     match m with
-    | Imported_from_vlib m | Normal m -> Module.kind m = Alias
     | Impl_of_virtual_module _ -> false
+    | Imported_from_vlib m | Normal m -> (
+      match Module.kind m with
+      | Alias _ -> true
+      | _ -> false)
   in
   if is_alias then Memo.return (Action_builder.return [])
   else

src/dune_rules/dune_file.ml

@@ -2143,11 +2143,16 @@ module Include_subdirs = struct
     | Include of qualification
 
   let decode ~enable_qualified =
-    let opts_list =
-      [ ("no", No); ("unqualified", Include Unqualified) ]
-      @ if enable_qualified then [ ("qualified", Include Qualified) ] else []
-    in
-    enum opts_list
+    sum
+      [ ("no", return No)
+      ; ("unqualified", return (Include Unqualified))
+      ; ( "qualified"
+        , let+ () =
+            if enable_qualified then return ()
+            else Syntax.since Stanza.syntax (3, 7)
+          in
+          Include Qualified )
+      ]
 end
 
 module Library_redirect = struct