fix(rules): canonical paths in aliases (#6963)

The canonical paths were all wrong for modules with (include_subdirs qualified). This PR addresses the problem. Signed-off-by: Rudi Grinberg <[email protected]>
ocaml · Jan 30, 2023 · 4eb93fd · 4eb93fd
1 parent d5fa2d3
commit 4eb93fd
Show file tree

Hide file tree

Showing 5 changed files with 130 additions and 71 deletions.
diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml
@@ -359,26 +359,23 @@ module Alias_module = struct
 
   type alias =
     { local_name : Module_name.t
+    ; canonical_path : Module_name.Path.t
     ; obj_name : Module_name.Unique.t
     }
 
   type t =
-    { main_module : Module_name.t option
-    ; aliases : alias list
+    { aliases : alias list
     ; shadowed : Module_name.t list
     }
 
-  let to_ml { main_module; aliases; shadowed } =
+  let to_ml { aliases; shadowed } =
     let b = Buffer.create 16 in
     Buffer.add_string b "(* generated by dune *)\n";
-    let main_module = main_module |> Option.map ~f:Module_name.to_string in
-    List.iter aliases ~f:(fun { local_name; obj_name } ->
-        let local_name = Module_name.to_string local_name in
-        (match main_module with
-        | None -> ()
-        | Some main_module ->
-          Printf.bprintf b "\n(** @canonical %s.%s *)" main_module local_name);
-        Printf.bprintf b "\nmodule %s = %s\n" local_name
+    List.iter aliases ~f:(fun { canonical_path; local_name; obj_name } ->
+        Printf.bprintf b "\n(** @canonical %s *)"
+          (Module_name.Path.to_string canonical_path);
+        Printf.bprintf b "\nmodule %s = %s\n"
+          (Module_name.to_string local_name)
           (Module_name.Unique.to_name ~loc:Loc.none obj_name
           |> Module_name.to_string));
     List.iter shadowed ~f:(fun shadowed ->
@@ -389,33 +386,32 @@ module Alias_module = struct
           (Module_name.to_string shadowed));
     Buffer.contents b
 
-  let of_modules project modules ~alias_module ~group =
-    let main_module = Modules.main_module_name modules in
+  let of_modules project modules group =
     let aliases =
-      Module_name.Map.to_list_map group ~f:(fun local_name m ->
-          let obj_name = Module.obj_name m in
-          { local_name; obj_name })
+      Modules.Group.for_alias group
+      |> List.map ~f:(fun (local_name, m) ->
+             let canonical_path = Modules.canonical_path modules group m in
+             let obj_name = Module.obj_name m in
+             { canonical_path; local_name; obj_name })
     in
     let shadowed =
       if Dune_project.dune_version project < (3, 5) then []
       else
-        match Modules.lib_interface modules with
-        | None -> []
-        | Some m -> (
-          match Module.kind m with
-          | Alias _ -> []
-          | _ -> [ Module.name alias_module ])
+        let lib_interface = Modules.Group.lib_interface group in
+        match Module.kind lib_interface with
+        | Alias _ -> []
+        | _ -> [ Module.name (Modules.Group.alias group) ]
     in
-    { main_module; aliases; shadowed }
+    { aliases; shadowed }
 end
 
-let build_alias_module cctx alias_module group =
-  let modules = Compilation_context.modules cctx in
+let build_alias_module cctx group =
   let alias_file () =
     let project = Compilation_context.scope cctx |> Scope.project in
-    Alias_module.of_modules project modules ~alias_module ~group
-    |> Alias_module.to_ml
+    let modules = Compilation_context.modules cctx in
+    Alias_module.of_modules project modules group |> Alias_module.to_ml
   in
+  let alias_module = Modules.Group.alias group in
   let cctx = Compilation_context.for_alias_module cctx alias_module in
   let sctx = Compilation_context.super_context cctx in
   let file = Option.value_exn (Module.file alias_module ~ml_kind:Impl) in
@@ -460,9 +456,9 @@ let build_all cctx =
   Memo.parallel_iter
     (Modules.fold_no_vlib_with_aliases modules ~init:[]
        ~normal:(fun x acc -> `Normal x :: acc)
-       ~alias:(fun m group acc -> `Alias (m, group) :: acc))
+       ~alias:(fun group acc -> `Alias group :: acc))
     ~f:(function
-      | `Alias (m, group) -> build_alias_module cctx m group
+      | `Alias group -> build_alias_module cctx group
       | `Normal m -> (
         match Module.kind m with
         | Alias _ -> assert false

diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml
@@ -207,8 +207,12 @@ module Mangle = struct
       | None -> base
       | Some prefix -> prefix :: base
     in
-    let name = Module_name.Unique.to_name ~loc:Loc.none obj_name in
-    let path = if has_lib_interface then [ name ] else interface :: path in
+    let name =
+      if has_lib_interface then
+        Module_name.Unique.to_name ~loc:Loc.none obj_name
+      else interface
+    in
+    let path = if has_lib_interface then [ name ] else path @ [ interface ] in
     Module.generated ~path ~obj_name ~kind ~src_dir name
 
   let wrap_module t m ~interface =
@@ -246,6 +250,8 @@ module Group = struct
     | Group of t
     | Module of Module.t
 
+  let alias t = t.alias
+
   module Of_trie = struct
     let of_trie ~src_dir ~mangle ~interface ~rev_path trie =
       let rec loop interface rev_path trie =
@@ -477,34 +483,42 @@ module Group = struct
       match Module_name.Map.find modules name with
       | Some (Group g) -> g
       | Some (Module m) ->
-        Code_error.raise "for_alias: unexpected module"
+        Code_error.raise "group_of_alias: unexpected module"
           [ ("m", Module.to_dyn m); ("alias", Module.to_dyn alias) ]
       | None ->
-        Code_error.raise "for_alias: not found"
-          [ ("alias", Module.to_dyn alias) ]
+        Code_error.raise "group_of_alias: not found"
+          [ ("name", Module_name.to_dyn name)
+          ; ("modules", Module_name.Map.to_dyn dyn_of_node modules)
+          ; ("alias", Module.to_dyn alias)
+          ]
 
     let path_of_alias_module alias =
       match Module.kind alias with
       | Alias for_ -> for_
-      | _ -> Code_error.raise "for_alias: not an alias module" []
+      | _ -> Code_error.raise "group_of_alias: not an alias module" []
 
-    let make_for_alias t alias path =
+    let make_group_of_alias t alias path =
       let rec loop (t : t) = function
         | [] -> t
         | name :: path ->
           let group = find_module alias t.modules name in
           loop group path
       in
-      let group = loop t path in
-      let modules = Module_name.Map.remove group.modules group.name in
-      Module_name.Map.map modules ~f:(fun (g : node) ->
-          match g with
-          | Module m -> m
-          | Group g -> lib_interface g)
+      loop t path
   end
 
-  let for_alias t alias =
-    For_alias.make_for_alias t alias (For_alias.path_of_alias_module alias)
+  let group_of_alias t alias =
+    For_alias.make_group_of_alias t alias (For_alias.path_of_alias_module alias)
+
+  let for_alias t =
+    Module_name.Map.remove t.modules t.name
+    |> Module_name.Map.to_list_map ~f:(fun name node ->
+           let m =
+             match node with
+             | Module m -> m
+             | Group g -> lib_interface g
+           in
+           (name, m))
 end
 
 module Unwrapped = struct
@@ -570,12 +584,12 @@ module Unwrapped = struct
         | Module m -> m
         | Group g -> Group.lib_interface g)
 
-  let for_alias t alias =
+  let group_of_alias t alias =
     match Group.For_alias.path_of_alias_module alias with
     | [] -> assert false
     | name :: path ->
       let group = Group.For_alias.find_module alias t name in
-      Group.For_alias.make_for_alias group alias path
+      Group.For_alias.make_group_of_alias group alias path
 
   module Memo_traversals = struct
     let parallel_map t ~f = Group.Memo_traversals.parallel_map_modules t ~f
@@ -611,7 +625,7 @@ module Wrapped = struct
         | Module m -> f m init
         | Group t -> Group.fold t ~f ~init)
 
-  let for_alias t m = Group.for_alias t.group m
+  let group_of_alias t m = Group.group_of_alias t.group m
 
   let encode { group; wrapped_compat; wrapped; toplevel_module = _ } =
     let open Dune_lang.Encoder in
@@ -920,25 +934,46 @@ let rec fold_no_vlib t ~init ~f =
   | Wrapped w -> Wrapped.fold w ~init ~f
   | Impl { vlib = _; impl } -> fold_no_vlib impl ~f ~init
 
-let rec for_alias t m =
-  match t with
-  | Stdlib _ | Singleton _ -> Module_name.Map.empty
-  | Unwrapped w -> Unwrapped.for_alias w m
-  | Wrapped w -> Wrapped.for_alias w m
-  | Impl { vlib; impl } ->
-    let impl = for_alias impl m in
-    let vlib = for_alias vlib m in
-    Module_name.Map.merge impl vlib ~f:(fun _ impl vlib ->
-        match (impl, vlib) with
-        | None, None -> assert false
-        | Some _, _ -> impl
-        | _, Some vlib -> Option.some_if (Module.visibility vlib = Public) vlib)
-
-let fold_no_vlib_with_aliases t ~init ~normal ~alias =
-  fold_no_vlib t ~init ~f:(fun m acc ->
-      match Module.kind m with
-      | Alias _ -> alias m (for_alias t m) acc
-      | _ -> normal m acc)
+let fold_no_vlib_with_aliases =
+  let rec group_of_alias t m =
+    match t with
+    | Wrapped w -> Some (Wrapped.group_of_alias w m)
+    | Unwrapped w -> Some (Unwrapped.group_of_alias w m)
+    | Impl { vlib; impl } -> (
+      let vlib = group_of_alias vlib m in
+      let impl = group_of_alias impl m in
+      match (vlib, impl) with
+      | None, None -> assert false
+      | Some _, None -> vlib
+      | None, Some _ -> impl
+      | Some vlib, Some impl ->
+        let modules =
+          Module_name.Map.merge vlib.modules impl.modules ~f:(fun _ vlib impl ->
+              match (vlib, impl) with
+              | None, None -> assert false
+              | _, Some _ -> impl
+              | Some vlib, _ ->
+                let vlib =
+                  match (vlib : Group.node) with
+                  | Module m -> m
+                  | Group g -> Group.lib_interface g
+                in
+                Option.some_if (Module.visibility vlib = Public) vlib
+                |> Option.map ~f:(fun m -> Group.Module m))
+        in
+        Some { impl with Group.modules })
+    | _ -> None
+  in
+  fun t ~init ~normal ~alias ->
+    fold_no_vlib t ~init ~f:(fun m acc ->
+        match Module.kind m with
+        | Alias _ -> (
+          match group_of_alias t m with
+          | None ->
+            Code_error.raise "alias module for group without alias"
+              [ ("t", to_dyn t); ("m", Module.to_dyn m) ]
+          | Some group -> alias group acc)
+        | _ -> normal m acc)
 
 type split_by_lib =
   { vlib : Module.t list
@@ -1131,3 +1166,19 @@ let source_dirs =
       Module.sources m
       |> List.fold_left ~init:acc ~f:(fun acc f ->
              Path.Set.add acc (Path.parent_exn f)))
+
+let canonical_path t (group : Group.t) m =
+  let path =
+    let path = Module.path m in
+    match Module_name.Map.find group.modules (Module.name m) with
+    | None | Some (Group.Module _) -> path
+    | Some (Group _) ->
+      (* The path for group interfaces always duplicates
+         the last component.
+
+         For example: foo/foo.ml would has the path [ "Foo"; "Foo" ] *)
+      path |> List.rev |> List.tl |> List.rev
+  in
+  match t with
+  | Impl { impl = Wrapped w; _ } | Wrapped w -> w.group.name :: path
+  | _ -> Module.path m
diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli
@@ -45,11 +45,23 @@ val singleton_exe : Module.t -> t
 
 val fold_no_vlib : t -> init:'acc -> f:(Module.t -> 'acc -> 'acc) -> 'acc
 
+module Group : sig
+  type t
+
+  val alias : t -> Module.t
+
+  val lib_interface : t -> Module.t
+
+  val for_alias : t -> (Module_name.t * Module.t) list
+end
+
+val canonical_path : t -> Group.t -> Module.t -> Module_name.Path.t
+
 val fold_no_vlib_with_aliases :
      t
   -> init:'acc
   -> normal:(Module.t -> 'acc -> 'acc)
-  -> alias:(Module.t -> Module.t Module_name.Map.t -> 'acc -> 'acc)
+  -> alias:(Group.t -> 'acc -> 'acc)
   -> 'acc
 
 val exe_unwrapped : Module.t Module_trie.t -> src_dir:Path.Build.t -> t

diff --git a/test/blackbox-tests/test-cases/include-qualified/basic.t/run.t b/test/blackbox-tests/test-cases/include-qualified/basic.t/run.t
@@ -13,15 +13,15 @@ Basic test showcasing the feature. Every directory creates a new level of aliasi
   contents of _build/default/lib/foolib__Foo.ml-gen
   (* generated by dune *)
 
-  (** @canonical Foolib.A *)
+  (** @canonical Foolib.Foo.A *)
   module A = Foolib__Foo__A
 
-  (** @canonical Foolib.Bar *)
+  (** @canonical Foolib.Foo.Bar *)
   module Bar = Foolib__Foo__Bar
   --------
   contents of _build/default/lib/foolib__Foo__A.ml-gen
   (* generated by dune *)
 
-  (** @canonical Foolib.B *)
+  (** @canonical Foolib.Foo.A.B *)
   module B = Foolib__Foo__A__B
   --------
diff --git a/test/blackbox-tests/test-cases/include-qualified/nested-lib-interface.t/run.t b/test/blackbox-tests/test-cases/include-qualified/nested-lib-interface.t/run.t
@@ -28,7 +28,7 @@ We are also allowed to write lib interface files at each level.
   contents of _build/default/lib/foolib__Bar__.ml-gen
   (* generated by dune *)
 
-  (** @canonical Foolib.Baz *)
+  (** @canonical Foolib.Bar.Baz *)
   module Baz = Foolib__Bar__Baz
 
   module Foolib__Bar__ = struct end