Load libraries true API using the main-module argument

NathanReb · NathanReb · commit fddf5582c58b · 2024-09-03T14:03:19.000+02:00
We now load the main module of the library first and then recursively
replace module aliases with the actual signature if the aliased module
is part of the library.

Signed-off-by: Nathan Rebours &lt;nathan.p.rebours@gmail.com&gt;
diff --git a/bin/api_diff.ml b/bin/api_diff.ml
@@ -7,8 +7,9 @@ let run (`Main_module main_module) (`Ref_cmi reference) (`Current_cmi current) =
       (Sys.is_directory reference, Sys.is_directory current, main_module)
     with
     | true, true, Some main_module ->
-        let+ reference_sig = Api_watch.Library.load reference
-        and+ current_sig = Api_watch.Library.load current in
+        let main_module = String.capitalize_ascii main_module in
+        let+ reference_sig = Api_watch.Library.load ~main_module reference
+        and+ current_sig = Api_watch.Library.load ~main_module current in
         let module_name = String.capitalize_ascii main_module in
         (reference_sig, current_sig, module_name)
     | false, false, main_module ->
diff --git a/dev-tools/dune b/dev-tools/dune
@@ -1,3 +1,3 @@
 (executable
- (name print_cmi)
- (libraries cmdliner compiler-libs.common))
+ (name print_api)
+ (libraries api-watch cmdliner compiler-libs.common))
diff --git a/dev-tools/print_api.ml b/dev-tools/print_api.ml
@@ -0,0 +1,63 @@
+let print_cmi path =
+  let cmi_infos = Cmi_format.read_cmi path in
+  Format.printf "cmi_name: %s\n" cmi_infos.cmi_name;
+  Format.printf "cmi_sign:\n";
+  Printtyp.signature Format.std_formatter cmi_infos.cmi_sign;
+  Format.printf "\n"
+
+let all_cmi_files path =
+  Sys.readdir path |> Array.to_list
+  |> List.filter (fun p -> Filename.check_suffix p ".cmi")
+  |> List.map (Filename.concat path)
+
+let run (`Main_module main_module) (`Input fn) =
+  let open CCResult.Infix in
+  match (Sys.is_directory fn, main_module) with
+  | false, _ ->
+      print_cmi fn;
+      Ok ()
+  | true, None ->
+      let cmi_files = all_cmi_files fn in
+      List.iter print_cmi cmi_files;
+      Ok ()
+  | true, Some main_module ->
+      let+ sig_ = Api_watch.Library.load ~main_module fn in
+      Printtyp.signature Format.std_formatter sig_;
+      Format.printf "\n"
+
+let named f = Cmdliner.Term.(app (const f))
+
+let main_module =
+  let docv = "MAIN_MODULE_NAME" in
+  let doc =
+    "The name of the library's main module. Ignored when input is a $(b,.cmi) \
+     file"
+  in
+  named
+    (fun x -> `Main_module x)
+    Cmdliner.Arg.(
+      value & opt (some string) None & info ~doc ~docv [ "main-module" ])
+
+let input_file =
+  let docv = "PATH" in
+  let doc =
+    "Path to the $(b,.cmi) file or lib directory. If $(docv) is directory\n\
+    \     and no $(b,--main-module) is provided, prints the API of all \
+     $(b,.cmi) files.\n\
+    \     If $(b,--main-module) is provided, prints the public API of the \
+     library."
+  in
+  named
+    (fun x -> `Input x)
+    Cmdliner.Arg.(required & pos 0 (some file) None & info ~doc ~docv [])
+
+let info =
+  let open Cmdliner in
+  Cmd.info "print_api" ~version:"%%VERSION%%" ~exits:Cmd.Exit.defaults
+    ~doc:"Pretty prints the API of a $(b,.cmi) file or a whole library"
+
+let term = Cmdliner.Term.(const run $ main_module $ input_file)
+
+let () =
+  let exit_code = Cmdliner.Cmd.eval_result (Cmdliner.Cmd.v info term) in
+  exit exit_code
diff --git a/dev-tools/print_cmi.ml b/dev-tools/print_cmi.ml
diff --git a/lib/library.ml b/lib/library.ml
@@ -1,52 +1,192 @@
-let collect_cmi_files dir =
+let mod_name file =
+  String.capitalize_ascii Filename.(remove_extension (basename file))
+
+let lazy_sig path =
+  Lazy.from_fun (fun () ->
+      let cmi_infos = Cmi_format.read_cmi path in
+      cmi_infos.cmi_sign)
+
+let collect_modules dir =
   try
     let files = Sys.readdir dir in
-    Ok
-      (Array.fold_left
-         (fun acc file ->
-           let path = Filename.concat dir file in
-           if (not (Sys.is_directory path)) && Filename.check_suffix file ".cmi"
-           then path :: acc
-           else acc)
-         [] files)
+    let map =
+      Array.fold_left
+        (fun acc file ->
+          let path = Filename.concat dir file in
+          if (not (Sys.is_directory path)) && Filename.check_suffix file ".cmi"
+          then String_map.add (mod_name file) (lazy_sig path) acc
+          else acc)
+        String_map.empty files
+    in
+    Ok map
   with Sys_error e ->
     Error (Printf.sprintf "Error reading directory %s: %s" dir e)
 
+let get_sig modname map =
+  Option.map Lazy.force (String_map.find_opt modname map)
+
 let load_cmi file_path =
   try
     let cmi_infos = Cmi_format.read_cmi file_path in
     Ok (cmi_infos.cmi_sign, cmi_infos.cmi_name)
   with e -> Error (Printexc.to_string e)
 
-let load project_path =
-  let open CCResult.Infix in
-  let* cmi_files = collect_cmi_files project_path in
-  let* signatures =
-    CCResult.map_l
-      (fun cmi_file ->
-        let+ signature, module_name = load_cmi cmi_file in
-        (module_name, signature))
-      cmi_files
+(* Attach a module name to its various representations, e.g. a [signature] or a
+   [module_type].
+   Mostly used to report lookup failures. *)
+type 'a named = { name : string; value : 'a }
+
+module Flat_path = struct
+  type component = Id of Ident.t | Comp of string
+  type t = component list
+
+  let from_path path =
+    match Path.flatten path with
+    | `Contains_apply -> None
+    | `Ok (id, comps) -> Some (Id id :: List.map (fun s -> Comp s) comps)
+
+  let modname_from_component = function Id id -> Ident.name id | Comp s -> s
+  let to_string t = String.concat "." (List.map modname_from_component t)
+end
+
+let rec path_in_module ~module_path flat_path =
+  match flat_path with
+  | [] -> module_path
+  | hd :: tl ->
+      let module_path =
+        Path.Pdot (module_path, Flat_path.modname_from_component hd)
+      in
+      path_in_module ~module_path tl
+
+let rewrite_mty_path mty path =
+  let open Types in
+  match mty with
+  | Mty_ident _ -> Mty_ident path
+  | Mty_alias _ -> Mty_alias path
+  | _ -> assert false
+
+let lookup_error ~path ~module_name =
+  Error (Printf.sprintf "Could not find module %s in %s" path module_name)
+
+let find_module modname sig_ =
+  let open Types in
+  let mty_opt =
+    List.find_map
+      (function
+        | Sig_module (id, _, { md_type; _ }, _, _)
+          when String.equal (Ident.name id) modname ->
+            Some md_type
+        | _ -> None)
+      sig_.value
   in
-  let merged_signature =
-    List.fold_left
-      (fun acc (module_name, signature) ->
-        String_map.add module_name signature acc)
-      String_map.empty signatures
+  match mty_opt with
+  | Some mty -> Ok mty
+  | None -> lookup_error ~path:modname ~module_name:sig_.name
+
+let rec find_module_in_sig ~library_modules path sig_ =
+  let open CCResult.Infix in
+  match (path : Flat_path.t) with
+  | [ last ] ->
+      let modname = Flat_path.modname_from_component last in
+      find_module modname sig_
+  | hd :: tl ->
+      let modname = Flat_path.modname_from_component hd in
+      let* mty = find_module modname sig_ in
+      find_module_in_md_type ~library_modules tl { name = modname; value = mty }
+  | [] -> assert false
+
+and find_module_in_md_type ~library_modules path mty =
+  let open CCResult.Infix in
+  match mty.value with
+  | Mty_signature s ->
+      find_module_in_sig ~library_modules path { name = mty.name; value = s }
+  | Mty_ident mty_path | Mty_alias mty_path -> (
+      let* expanded =
+        match Flat_path.from_path mty_path with
+        | None -> Ok None
+        | Some flat_mty_path ->
+            find_module_in_lib ~library_modules flat_mty_path
+      in
+      match expanded with
+      | Some expanded_mty ->
+          find_module_in_md_type ~library_modules path
+            { name = Path.name mty_path; value = expanded_mty }
+      | None ->
+          let expanded_path = path_in_module ~module_path:mty_path path in
+          Ok (rewrite_mty_path mty.value expanded_path))
+  | _ -> lookup_error ~path:(Flat_path.to_string path) ~module_name:mty.name
+
+and find_module_in_lib ~library_modules path :
+    (Types.module_type option, string) result =
+  let open Types in
+  let open CCResult.Infix in
+  match path with
+  | [ comp ] ->
+      let modname = Flat_path.modname_from_component comp in
+      let sig_opt = get_sig modname library_modules in
+      Ok (Option.map (fun s -> Mty_signature s) sig_opt)
+  | comp :: inner_path -> (
+      let modname = Flat_path.modname_from_component comp in
+      match get_sig modname library_modules with
+      | None -> Ok None
+      | Some parent_sig -> (
+          let* mty =
+            find_module_in_sig ~library_modules inner_path
+              { name = modname; value = parent_sig }
+          in
+          match mty with
+          | Mty_signature _ | Mty_functor _ -> Ok (Some mty)
+          | Mty_ident path' | Mty_alias path' -> (
+              match Flat_path.from_path path' with
+              | None -> Ok (Some mty)
+              | Some fpath -> find_module_in_lib ~library_modules fpath)))
+  | _ -> Ok None
+
+let rec expand_sig ~library_modules sig_ =
+  let open Types in
+  let open CCResult.Infix in
+  CCResult.map_l
+    (fun item ->
+      match item with
+      | Sig_module
+          ( id,
+            presence,
+            ({ md_type = Mty_ident path | Mty_alias path; _ } as mod_decl),
+            rs,
+            vis ) -> (
+          match Flat_path.from_path path with
+          | None -> Ok item
+          | Some fpath -> (
+              let* mty_opt = find_module_in_lib ~library_modules fpath in
+              match mty_opt with
+              | None -> Ok item
+              | Some mty ->
+                  let* expanded =
+                    match mty with
+                    | Mty_signature s ->
+                        let* expanded = expand_sig ~library_modules s in
+                        Ok (Mty_signature expanded)
+                    | _ -> Ok mty
+                  in
+                  let presence =
+                    match expanded with
+                    | Mty_alias _ -> presence
+                    | _ -> Mp_present
+                  in
+                  let mod_decl' = { mod_decl with md_type = expanded } in
+                  Ok (Sig_module (id, presence, mod_decl', rs, vis))))
+      | _ -> Ok item)
+    sig_
+
+let load ~main_module project_path =
+  let open CCResult.Infix in
+  let* library_modules = collect_modules project_path in
+  let* main_sig =
+    match get_sig main_module library_modules with
+    | Some s -> Ok s
+    | None ->
+        Error
+          (Printf.sprintf "Could not find main module %s in %s" main_module
+             project_path)
   in
-  Ok
-    (String_map.fold
-       (fun module_name module_sig acc ->
-         Types.Sig_module
-           ( Ident.create_local module_name,
-             Mp_present,
-             {
-               md_type = Mty_signature module_sig;
-               md_attributes = [];
-               md_loc = Location.none;
-               md_uid = Types.Uid.internal_not_actually_unique;
-             },
-             Trec_not,
-             Exported )
-         :: acc)
-       merged_signature [])
+  expand_sig ~library_modules main_sig
diff --git a/lib/library.mli b/lib/library.mli
@@ -1,2 +1,2 @@
 val load_cmi : string -> (Types.signature * string, string) result
-val load : string -> (Types.signature, string) result
+val load : main_module:string -> string -> (Types.signature, string) result
diff --git a/tests/api-diff/run.t b/tests/api-diff/run.t
@@ -364,17 +364,17 @@ Build the second version
   $ cd project_v2 && dune build && cd ..
 
 Run the api-diff tool on the two project versions
-  $ api-diff --main-module myproject  project_v1/_build/default/lib/.mylib.objs/byte project_v2/_build/default/lib/.mylib.objs/byte
-  diff module Myproject.Mylib__Math:
+  $ api-diff --main-module mylib  project_v1/_build/default/lib/.mylib.objs/byte project_v2/_build/default/lib/.mylib.objs/byte
+  diff module Mylib.Math:
   -val add : int -> int -> int
   +val add : int -> int -> int -> int
   +val multiply : int -> int -> int
   +module New_module: sig val hello : unit -> string end
   
-  diff module Myproject.Mylib__Math.Advanced:
+  diff module Mylib.Math.Advanced:
   +val cube : int -> int
   
-  diff module Myproject.Mylib__Utils:
+  diff module Mylib.Utils:
   +val triple : int -> int
   
   [1]

Original file line number	Diff line number	Diff line change
`@@ -1,2 +1,2 @@`
`1`	`1`	`val load_cmi : string -> (Types.signature * string, string) result`
`2`		`-val load : string -> (Types.signature, string) result`
	`2`	`+val load : main_module:string -> string -> (Types.signature, string) result`