feature: enable (include_subdirs qualified)

Signed-off-by: Rudi Grinberg <[email protected]>

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/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
+  | _ -> (
+    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

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

@@ -21,14 +21,14 @@ module Modules = struct
     ; executables : (Modules.t * Path.Build.t Obj_dir.t) String.Map.t
     ; melange_emits : (Modules.t * Path.Build.t Obj_dir.t) String.Map.t
     ; (* Map from modules to the origin they are part of *)
-      rev_map : Origin.t Module_name.Map.t
+      rev_map : Origin.t Module_name.Path.Map.t
     }
 
   let empty =
     { libraries = Lib_name.Map.empty
     ; executables = String.Map.empty
     ; melange_emits = String.Map.empty
-    ; rev_map = Module_name.Map.empty
+    ; rev_map = Module_name.Path.Map.empty
     }
 
   type groups =
@@ -79,29 +79,30 @@ module Modules = struct
     in
     let rev_map =
       let modules =
-        let by_name (origin : Origin.t) =
+        let by_path (origin : Origin.t) =
           Modules.fold_user_available ~init:[] ~f:(fun m acc ->
-              (Module.name m, origin) :: acc)
+              (Module.path m, origin) :: acc)
         in
         List.concat
-          [ List.concat_map libs ~f:(fun (l, m, _) -> by_name (Library l) m)
-          ; List.concat_map exes ~f:(fun (e, m, _) -> by_name (Executables e) m)
-          ; List.concat_map emits ~f:(fun (l, m, _) -> by_name (Melange l) m)
+          [ List.concat_map libs ~f:(fun (l, m, _) -> by_path (Library l) m)
+          ; List.concat_map exes ~f:(fun (e, m, _) -> by_path (Executables e) m)
+          ; List.concat_map emits ~f:(fun (l, m, _) -> by_path (Melange l) m)
           ]
       in
-      match Module_name.Map.of_list modules with
+      match Module_name.Path.Map.of_list modules with
       | Ok x -> x
-      | Error (name, _, _) ->
-        let open Module_name.Infix in
+      | Error (path, _, _) ->
         let locs =
           List.filter_map modules ~f:(fun (n, origin) ->
-              Option.some_if (n = name) (Origin.loc origin))
+              Option.some_if
+                (Ordering.is_eq (Module_name.Path.compare n path))
+                (Origin.loc origin))
           |> List.sort ~compare:Loc.compare
         in
         User_error.raise
           ~loc:(Loc.drop_position (List.hd locs))
           [ Pp.textf "Module %S is used in several stanzas:"
-              (Module_name.to_string name)
+              (Module_name.Path.to_string path)
           ; Pp.enumerate locs ~f:(fun loc ->
                 Pp.verbatim (Loc.to_file_colon_line loc))
           ; Pp.text
@@ -215,7 +216,9 @@ let modules_and_obj_dir t ~for_ =
 
 let modules t ~for_ = modules_and_obj_dir t ~for_ |> fst
 
-let find_origin (t : t) name = Module_name.Map.find t.modules.rev_map name
+let find_origin (t : t) name =
+  (* TODO generalize to any path *)
+  Module_name.Path.Map.find t.modules.rev_map [ name ]
 
 let virtual_modules ~lookup_vlib vlib =
   let info = Lib.info vlib in
@@ -361,7 +364,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 +403,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