feature: enable (include_subdirs qualified)

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

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

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

@@ -189,9 +189,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/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

src/dune_rules/link_time_code_gen.ml

@@ -28,7 +28,7 @@ let generate_and_compile_module cctx ~precompiled_cmi ~name ~lib ~code ~requires
       let main_module_name = Option.value_exn main_module_name in
       (* XXX this is fishy. We shouldn't be introducing a toplevel module into a
          wrapped library with a single module *)
-      Module.with_wrapper gen_module ~main_module_name
+      Module.with_wrapper gen_module ~main_module_name ~path:[]
   in
   let open Memo.O in
   let* () =

src/dune_rules/merlin.ml

@@ -1,5 +1,15 @@
 open Import
 
+let remove_extension file =
+  let dir = Path.Build.parent_exn file in
+  let basename =
+    match Path.Build.basename file |> Filename.chop_extension with
+    | s -> s
+    | exception Code_error.E _ ->
+      Code_error.raise "opens" [ ("file", Path.Build.to_dyn file) ]
+  in
+  Path.Build.relative dir basename
+
 module Processed = struct
   (* The actual content of the merlin file as built by the [Unprocessed.process]
      function from the unprocessed info gathered through [gen_rules]. The first
@@ -40,14 +50,15 @@ module Processed = struct
     { config : config
     ; modules : Module_name.t list
     ; pp_config : pp_flag option Module_name.Per_item.t
+    ; per_module_opens : Module_name.t list Path.Build.Map.t
     }
 
   module D = struct
     type nonrec t = t
 
     let name = "merlin-conf"
 
-    let version = 3
+    let version = 4
 
     let to_dyn _ = Dyn.String "Use [dune ocaml dump-dot-merlin] instead"
   end
@@ -68,7 +79,7 @@ module Processed = struct
 
   let serialize_path = Path.to_absolute_filename
 
-  let to_sexp ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions } =
+  let to_sexp ~opens ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions } =
     let make_directive tag value = Sexp.List [ Atom tag; value ] in
     let make_directive_of_path tag path =
       make_directive tag (Sexp.Atom (serialize_path path))
@@ -94,6 +105,16 @@ module Processed = struct
               (Sexp.List (List.map ~f:(fun s -> Sexp.Atom s) flags))
           ]
       in
+      let flags =
+        match opens with
+        | [] -> flags
+        | flags ->
+          [ make_directive "FLG"
+              (Sexp.List
+                 (List.concat_map flags ~f:(fun name ->
+                      [ Sexp.Atom "-open"; Atom (Module_name.to_string name) ])))
+          ]
+      in
       match pp with
       | None -> flags
       | Some { flag; args } ->
@@ -147,29 +168,36 @@ module Processed = struct
           print "\n");
     Buffer.contents b
 
-  let get { modules; pp_config; config } ~filename =
+  let opens per_module_opens file =
+    let file = remove_extension file in
+    Path.Build.Map.find per_module_opens file
+
+  let get { per_module_opens; modules; pp_config; config } ~file =
     (* We only match the first part of the filename : foo.ml -> foo foo.cppo.ml
        -> foo *)
     let fname =
+      let filename = Path.Build.basename file in
       String.lsplit2 filename ~on:'.'
       |> Option.map ~f:fst
       |> Option.value ~default:filename
       |> String.lowercase
     in
+    let opens = opens per_module_opens file in
     List.find_opt modules ~f:(fun name ->
         let fname' = Module_name.to_string name |> String.lowercase in
         String.equal fname fname')
     |> Option.map ~f:(fun name ->
            let pp = Module_name.Per_item.get pp_config name in
-           to_sexp ~pp config)
+           let opens = Option.value_exn opens in
+           to_sexp ~opens ~pp config)
 
   let print_file path =
     match load_file path with
     | Error msg -> Printf.eprintf "%s\n" msg
-    | Ok { modules; pp_config; config } ->
+    | Ok { per_module_opens = _; modules; pp_config; config } ->
       let pp_one module_ =
         let pp = Module_name.Per_item.get pp_config module_ in
-        let sexp = to_sexp ~pp config in
+        let sexp = to_sexp ~opens:[] ~pp config in
         let open Pp.O in
         Pp.vbox (Pp.text (Module_name.to_string module_))
         ++ Pp.newline
@@ -196,6 +224,7 @@ module Processed = struct
                (acc_pp, acc_obj, acc_src, acc_flags, acc_ext)
                { modules = _
                ; pp_config
+               ; per_module_opens = _
                ; config =
                    { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions }
                }
@@ -264,16 +293,7 @@ module Unprocessed = struct
       Path.Set.singleton
       @@ obj_dir_of_lib `Private mode (Obj_dir.of_local obj_dir)
     in
-    let flags =
-      Ocaml_flags.common
-      @@
-      match Modules.alias_module modules with
-      | None -> flags
-      | Some m ->
-        Ocaml_flags.prepend_common
-          [ "-open"; Module_name.to_string (Module.name m) ]
-          flags
-    in
+    let flags = Ocaml_flags.common flags in
     let extensions = Dialect.DB.extensions_for_merlin dialects in
     let config =
       { stdlib_dir
@@ -420,12 +440,22 @@ module Unprocessed = struct
       in
       { Processed.stdlib_dir; src_dirs; obj_dirs; flags; extensions }
     and+ pp_config = pp_config t sctx ~expander in
+    let per_module_opens =
+      Modules.fold_no_vlib modules ~init:Path.Build.Map.empty ~f:(fun m init ->
+          Module.sources m
+          |> List.fold_left ~init ~f:(fun acc file ->
+                 let file = Path.as_in_build_dir_exn file |> remove_extension in
+                 let opens =
+                   Modules.alias_for modules m |> List.map ~f:Module.name
+                 in
+                 Path.Build.Map.set acc file opens))
+    in
     let modules =
       (* And copy for each module the resulting pp flags *)
       Modules.fold_no_vlib modules ~init:[] ~f:(fun m acc ->
           Module.name m :: acc)
     in
-    { Processed.modules; pp_config; config }
+    { Processed.modules; pp_config; config; per_module_opens }
 end
 
 let dot_merlin sctx ~dir ~more_src_dirs ~expander (t : Unprocessed.t) =

src/dune_rules/merlin.mli

@@ -37,7 +37,7 @@ module Processed : sig
       print the resulting configuration in dot-merlin syntax. *)
   val print_generic_dot_merlin : Path.t list -> unit
 
-  val get : t -> filename:string -> Sexp.t option
+  val get : t -> file:Path.Build.t -> Sexp.t option
 end
 
 val make :

src/dune_rules/ml_sources.ml

@@ -361,7 +361,9 @@ let modules_of_stanzas dune_file ~dir ~scope ~lookup_vlib ~modules =
           let project = Scope.project scope in
           if Dune_project.wrapped_executables project then
             Modules_group.make_wrapped ~src_dir:dir ~modules `Exe
-          else Modules_group.exe_unwrapped modules
+          else
+            let modules = Module_trie.to_map modules in
+            Modules_group.exe_unwrapped modules
         in
         let obj_dir = Dune_file.Executables.obj_dir ~dir exes in
         let modules =
@@ -398,30 +400,34 @@ let modules_of_stanzas dune_file ~dir ~scope ~lookup_vlib ~modules =
       | _ -> Memo.return `Skip)
   >>| filter_partition_map
 
-let check_no_qualified (loc, include_subdirs) =
-  if include_subdirs = Dune_file.Include_subdirs.Include Qualified then
-    User_error.raise ~loc
-      [ Pp.text "(include_subdirs qualified) is not supported yet" ]
-
-let make dune_file ~dir ~scope ~lib_config ~loc ~lookup_vlib ~include_subdirs
+let make dune_file ~dir ~scope ~lib_config ~loc ~lookup_vlib
+    ~include_subdirs:(_loc, (include_subdirs : Dune_file.Include_subdirs.t))
     ~dirs =
   let+ modules_of_stanzas =
-    check_no_qualified include_subdirs;
     let modules =
       let dialects = Dune_project.dialects (Scope.project scope) in
-      List.fold_left dirs ~init:Module_name.Map.empty
-        ~f:(fun acc ((dir : Path.Build.t), _local, files) ->
-          let modules = modules_of_files ~dialects ~dir ~files in
-          Module_name.Map.union acc modules ~f:(fun name x y ->
-              User_error.raise ~loc
-                [ Pp.textf "Module %S appears in several directories:"
-                    (Module_name.to_string name)
-                ; Pp.textf "- %s"
-                    (Path.to_string_maybe_quoted (Module.Source.src_dir x))
-                ; Pp.textf "- %s"
-                    (Path.to_string_maybe_quoted (Module.Source.src_dir y))
-                ; Pp.text "This is not allowed, please rename one of them."
-                ]))
+      match include_subdirs with
+      | Include Qualified ->
+        List.fold_left dirs ~init:Module_trie.empty
+          ~f:(fun acc ((dir : Path.Build.t), local, files) ->
+            let modules = modules_of_files ~dialects ~dir ~files in
+            let path = List.map local ~f:Module_name.of_string in
+            Module_trie.set_map acc path modules)
+      | No | Include Unqualified ->
+        List.fold_left dirs ~init:Module_name.Map.empty
+          ~f:(fun acc ((dir : Path.Build.t), _local, files) ->
+            let modules = modules_of_files ~dialects ~dir ~files in
+            Module_name.Map.union acc modules ~f:(fun name x y ->
+                User_error.raise ~loc
+                  [ Pp.textf "Module %S appears in several directories:"
+                      (Module_name.to_string name)
+                  ; Pp.textf "- %s"
+                      (Path.to_string_maybe_quoted (Module.Source.src_dir x))
+                  ; Pp.textf "- %s"
+                      (Path.to_string_maybe_quoted (Module.Source.src_dir y))
+                  ; Pp.text "This is not allowed, please rename one of them."
+                  ]))
+        |> Module_trie.of_map
     in
     modules_of_stanzas dune_file ~dir ~scope ~lookup_vlib ~modules
   in

src/dune_rules/ml_sources.mli

@@ -60,5 +60,5 @@ val make :
   -> loc:Loc.t
   -> lookup_vlib:(loc:Loc.t -> dir:Path.Build.t -> t Memo.t)
   -> include_subdirs:Loc.t * Dune_file.Include_subdirs.t
-  -> dirs:(Path.Build.t * 'a list * String.Set.t) list
+  -> dirs:(Path.Build.t * string list * String.Set.t) list
   -> t Memo.t

src/dune_rules/module.ml

@@ -116,10 +116,13 @@ type t =
   ; pp : (string list Action_builder.t * Sandbox_config.t) option
   ; visibility : Visibility.t
   ; kind : Kind.t
+  ; path : Module_name.Path.t
   }
 
 let name t = t.source.name
 
+let path t = t.path
+
 let kind t = t.kind
 
 let pp_flags t = t.pp
@@ -158,7 +161,7 @@ let of_source ?obj_name ~visibility ~(kind : Kind.t) (source : Source.t) =
       Module_name.Unique.of_path_assuming_needs_no_mangling_allow_invalid
         file.path
   in
-  { source; obj_name; pp = None; visibility; kind }
+  { source; obj_name; pp = None; visibility; kind; path = [] }
 
 let has t ~ml_kind =
   match (ml_kind : Ml_kind.t) with
@@ -175,8 +178,13 @@ let iter t ~f =
   Memo.parallel_iter Ml_kind.all ~f:(fun kind ->
       Memo.Option.iter (Ml_kind.Dict.get t.source.files kind) ~f:(f kind))
 
-let with_wrapper t ~main_module_name =
-  { t with obj_name = Module_name.wrap t.source.name ~with_:main_module_name }
+let with_wrapper t ~main_module_name ~path =
+  let with_ = main_module_name :: path in
+  { t with obj_name = Module_name.wrap t.source.name ~with_ }
+
+let set_path_and_obj t ~main_module_name ~path =
+  assert (Module_name.equal (Option.value_exn (List.last path)) (name t));
+  { t with obj_name = Module_name.Path.wrap (main_module_name :: path); path }
 
 let add_file t kind file =
   let source = Source.add_file t.source kind file in
@@ -196,13 +204,14 @@ let src_dir t = Source.src_dir t.source
 
 let set_pp t pp = { t with pp }
 
-let to_dyn { source; obj_name; pp; visibility; kind } =
+let to_dyn { source; obj_name; pp; visibility; kind; path } =
   Dyn.record
     [ ("source", Source.to_dyn source)
     ; ("obj_name", Module_name.Unique.to_dyn obj_name)
     ; ("pp", Dyn.(option string) (Option.map ~f:(fun _ -> "has pp") pp))
     ; ("visibility", Visibility.to_dyn visibility)
     ; ("kind", Kind.to_dyn kind)
+    ; ("path", Module_name.Path.to_dyn path)
     ]
 
 let ml_gen = ".ml-gen"
@@ -248,8 +257,8 @@ end
 module Obj_map_traversals = Memo.Make_map_traversals (Obj_map)
 
 let encode
-    ({ source = { name; files = _ }; obj_name; pp = _; visibility; kind } as t)
-    =
+    ({ path; source = { name; files = _ }; obj_name; pp = _; visibility; kind }
+    as t) =
   let open Dune_lang.Encoder in
   let has_impl = has t ~ml_kind:Impl in
   let kind =
@@ -262,6 +271,7 @@ let encode
   record_fields
     [ field "name" Module_name.encode name
     ; field "obj_name" Module_name.Unique.encode obj_name
+    ; field_l "path" (fun x -> x) (Module_name.Path.encode path)
     ; field "visibility" Visibility.encode visibility
     ; field_o "kind" Kind.encode kind
     ; field_b "impl" has_impl
@@ -277,6 +287,7 @@ let decode ~src_dir =
   fields
     (let+ name = field "name" Module_name.decode
      and+ obj_name = field "obj_name" Module_name.Unique.decode
+     and+ path = field ~default:[] "path" Module_name.Path.decode
      and+ visibility = field "visibility" Visibility.decode
      and+ kind = field_o "kind" Kind.decode
      and+ impl = field_b "impl"
@@ -296,7 +307,8 @@ let decode ~src_dir =
      let intf = file intf Intf in
      let impl = file impl Impl in
      let source = Source.make ?impl ?intf name in
-     of_source ~obj_name ~visibility ~kind source)
+     let t = of_source ~obj_name ~visibility ~kind source in
+     { t with path })
 
 let pped =
   map_files ~f:(fun _kind (file : File.t) ->
@@ -315,8 +327,12 @@ let ml_source =
 
 let set_src_dir t ~src_dir = map_files t ~f:(fun _ -> File.set_src_dir ~src_dir)
 
-let generated ~(kind : Kind.t) ~src_dir name =
-  let obj_name = Module_name.Unique.of_name_assuming_needs_no_mangling name in
+let generated ?obj_name ~(kind : Kind.t) ~src_dir name =
+  let obj_name =
+    match obj_name with
+    | Some obj_name -> obj_name
+    | None -> Module_name.Unique.of_name_assuming_needs_no_mangling name
+  in
   let source =
     let impl =
       let basename = String.uncapitalize (Module_name.to_string name) in