Move the shape lookup code into xref2, where other resolution happens

Also simplify the interfaces of the loader a bit.

Author: jonludlam

src/loader/implementation.ml

@@ -455,13 +455,10 @@ let anchor_of_identifier id =
   in
   anchor_of_identifier [] id |> String.concat "."
 
-let of_cmt (source_id_opt : Odoc_model.Paths.Identifier.SourcePage.t option)
-    (id : Odoc_model.Paths.Identifier.RootModule.t) (cmt : Cmt_format.cmt_infos)
+let of_cmt (source_id : Odoc_model.Paths.Identifier.SourcePage.t)
+    (id : Odoc_model.Paths.Identifier.RootModule.t) (structure : Typedtree.structure)
+    (uid_to_loc : Warnings.loc Types.Uid.Tbl.t)
     =
-  let ttree = cmt.cmt_annots in
-  match (source_id_opt, ttree, cmt.cmt_impl_shape) with
-  | Some source_id, Cmt_format.Implementation structure, Some shape ->
-      let uid_to_loc = cmt.cmt_uid_to_loc in
       let env = Ident_env.empty () in
       let vs =
         Analysis.structure (env, uid_to_loc)
@@ -504,14 +501,10 @@ let of_cmt (source_id_opt : Odoc_model.Paths.Identifier.SourcePage.t option)
           uid_to_loc_map
       in
 
-      ( Some (shape, uid_to_id),
-        postprocess_poses source_id vs uid_to_id uid_to_loc )
-  | None, _, Some shape ->
-      (Some (shape, Shape.Uid.Map.empty), [] (* At least preserve the shape *))
-  | _ -> (None, [])
+      (uid_to_id, postprocess_poses source_id vs uid_to_id uid_to_loc )
 
 #else
 
-let of_cmt _ _ _ = None, []
+let of_cmt _ _ _ _ = []
 
 #endif

src/loader/implementation.mli

@@ -1,8 +1,8 @@
 val of_cmt :
-  Odoc_model.Paths.Identifier.SourcePage.t option ->
+  Odoc_model.Paths.Identifier.SourcePage.t ->
   Odoc_model.Paths.Identifier.RootModule.t ->
-  Cmt_format.cmt_infos ->
-  Lookup_def.t option * Odoc_model.Lang.Source_info.infos
+  Typedtree.structure -> Warnings.loc Types.Uid.Tbl.t ->
+  Odoc_model.Paths.Identifier.Id.source_location Odoc_model.Compat.shape_uid_map * Odoc_model.Lang.Source_info.infos
 (** Extract all implementation information from a [cmt]: the shape, and the
     {{!Odoc_model.Lang.Source_info.infos}source infos} (local and global
     definitions and occurrences).

src/loader/odoc_loader.ml

@@ -1,8 +1,6 @@
 open Result
 module Error = Odoc_model.Error
 
-module Lookup_def = Lookup_def
-
 let read_string parent_definition filename text =
   let location =
     let pos =
@@ -46,9 +44,17 @@ exception Make_root_error of string
 
 (** [cmt_info.cmt_annots = Implementation _] *)
 let read_cmt_infos' source_id_opt id cmt_info =
-  match Implementation.of_cmt source_id_opt id cmt_info with
-  | None, _ -> None
-  | Some shape, jmp_infos -> Some (shape, jmp_infos)
+  match Odoc_model.Compat.shape_of_cmt_infos cmt_info with
+  | Some shape -> begin
+    let uid_to_loc = cmt_info.cmt_uid_to_loc in
+    match source_id_opt, cmt_info.cmt_annots with
+    | Some source_id, Implementation impl ->
+      let (map, source_infos) = Implementation.of_cmt source_id id impl uid_to_loc in
+      (Some shape, map, Some { Odoc_model.Lang.Source_info.id=source_id; infos = source_infos})
+    | _, _ ->
+      (Some shape, Odoc_model.Compat.empty_map, None)
+    end
+  | None -> (None, Odoc_model.Compat.empty_map, None)
 
 let read_cmt_infos source_id_opt id ~filename () =
   match Cmt_format.read_cmt filename with
@@ -59,7 +65,7 @@ let read_cmt_infos source_id_opt id ~filename () =
       | _ -> raise Not_an_implementation)
 
 let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
-    ?canonical content =
+    ?canonical ?shape ~uid_to_id ~source_info content =
   let open Odoc_model.Lang.Compilation_unit in
   let interface, digest =
     match interface with
@@ -95,16 +101,18 @@ let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
     expansion = None;
     linked = false;
     canonical;
-    source_info = None;
+    source_info;
+    shape;
+    uid_to_id;
   }
 
 let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id
-    ?canonical sg =
+    ?canonical ?shape ~uid_to_id sg =
   let content = Odoc_model.Lang.Compilation_unit.Module sg in
   make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
-    ?canonical content
+    ?canonical ?shape ~uid_to_id content
 
-let read_cmti ~make_root ~parent ~filename () =
+let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt () =
   let cmt_info = Cmt_format.read_cmt filename in
   match cmt_info.cmt_annots with
   | Interface intf -> (
@@ -118,8 +126,15 @@ let read_cmti ~make_root ~parent ~filename () =
               cmt_info.cmt_builddir )
           in
           let id, sg, canonical = Cmti.read_interface parent name intf in
+          let (shape, uid_to_id, source_info) =
+            match cmt_filename_opt with
+            | Some cmt_filename ->
+              read_cmt_infos source_id_opt id ~filename:cmt_filename ()
+            | None ->
+              (None, Odoc_model.Compat.empty_map, None)
+          in
           compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports
-            ~interface ~sourcefile ~name ~id ?canonical sg)
+            ~interface ~sourcefile ~name ~id ?shape ~uid_to_id ~source_info ?canonical sg)
   | _ -> raise Not_an_interface
 
 let read_cmt ~make_root ~parent ~filename ~source_id_opt () =
@@ -161,14 +176,14 @@ let read_cmt ~make_root ~parent ~filename ~source_id_opt () =
               items
           in
           let content = Odoc_model.Lang.Compilation_unit.Pack items in
-          ( make_compilation_unit ~make_root ~imports ~interface ~sourcefile
-              ~name ~id content,
-            None )
+          make_compilation_unit ~make_root ~imports ~interface ~sourcefile
+              ~name ~id ~uid_to_id:Odoc_model.Compat.empty_map ~source_info:None content
       | Implementation impl ->
           let id, sg, canonical = Cmt.read_implementation parent name impl in
-          ( compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile
-              ~name ~id ?canonical sg,
-            read_cmt_infos' source_id_opt id cmt_info )
+          let (shape, uid_to_id, source_info) =
+            read_cmt_infos source_id_opt id ~filename () in
+          compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile
+              ~name ~id ?canonical ?shape ~uid_to_id ~source_info sg
       | _ -> raise Not_an_implementation)
 
 let read_cmi ~make_root ~parent ~filename () =
@@ -179,7 +194,7 @@ let read_cmi ~make_root ~parent ~filename () =
         Cmi.read_interface parent name
           (Odoc_model.Compat.signature cmi_info.cmi_sign)
       in
-      compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg
+      compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id ~source_info:None ~uid_to_id:Odoc_model.Compat.empty_map sg
   | _ -> raise Corrupted
 
 (** Catch errors from reading the object files and some internal errors *)
@@ -195,11 +210,8 @@ let wrap_errors ~filename f =
       | Not_an_interface -> not_an_interface filename
       | Make_root_error m -> error_msg filename m)
 
-let read_cmt_infos source_id_opt id ~filename =
-  wrap_errors ~filename (read_cmt_infos source_id_opt id ~filename)
-
-let read_cmti ~make_root ~parent ~filename =
-  wrap_errors ~filename (read_cmti ~make_root ~parent ~filename)
+let read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt =
+  wrap_errors ~filename (read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt)
 
 let read_cmt ~make_root ~parent ~filename ~source_id_opt =
   wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~source_id_opt)

src/loader/odoc_loader.mli

@@ -2,8 +2,6 @@ open Result
 open Odoc_model
 open Odoc_model.Paths
 
-module Lookup_def = Lookup_def
-
 type make_root =
   module_name:string ->
   digest:Digest.t ->
@@ -15,30 +13,22 @@ val read_string :
   string ->
   (Comment.docs_or_stop, Error.t) result Error.with_warnings
 
-val read_cmt_infos :
-  Identifier.SourcePage.t option ->
-  Identifier.RootModule.t ->
-  filename:string ->
-  ((Lookup_def.t * Lang.Source_info.infos) option, Error.t) result
-  Error.with_warnings
-(** Read the shape from a .cmt file. *)
-
 val read_cmti :
   make_root:make_root ->
   parent:Identifier.ContainerPage.t option ->
   filename:string ->
+  source_id_opt:Identifier.SourcePage.t option ->
+  cmt_filename_opt:string option ->
   (Lang.Compilation_unit.t, Error.t) result Error.with_warnings
 
 val read_cmt :
   make_root:make_root ->
   parent:Identifier.ContainerPage.t option ->
   filename:string ->
   source_id_opt:Identifier.SourcePage.t option ->
-  ( Lang.Compilation_unit.t * (Lookup_def.t * Lang.Source_info.infos) option,
-    Error.t )
+  ( Lang.Compilation_unit.t,  Error.t )
   result
   Error.with_warnings
-(** The shape is not returned in case of a pack. *)
 
 val read_cmi :
   make_root:make_root ->

src/model/compat.cppo.ml

@@ -223,3 +223,27 @@ and modtype_declaration : Types.modtype_declaration -> modtype_declaration = fun
 
 
 #endif
+
+(* Shapes were introduced in OCaml 4.14.0. They're used for resolving to source-code
+   locations *)
+#if OCAML_VERSION >= (4,14,0)
+
+type shape = Shape.t
+
+type 'a shape_uid_map = 'a Shape.Uid.Map.t
+
+let empty_map = Shape.Uid.Map.empty
+
+let shape_of_cmt_infos : Cmt_format.cmt_infos -> shape option = fun x -> x.cmt_impl_shape
+
+#else
+
+type shape = unit
+
+type 'a shape_uid_map = unit
+
+let empty_map = ()
+
+let shape_of_cmt_infos : Cmt_format.cmt_infos -> shape option = fun _ -> None
+
+#endif

src/model/lang.ml

@@ -486,6 +486,8 @@ module rec Compilation_unit : sig
     linked : bool;  (** Whether this unit has been linked. *)
     canonical : Path.Module.t option;
     source_info : Source_info.t option;
+    shape : Compat.shape option;
+    uid_to_id : Paths.Identifier.SourceLocation.t Compat.shape_uid_map;
   }
 end =
   Compilation_unit

src/odoc/bin/main.ml

@@ -168,18 +168,13 @@ end = struct
 
   let compile hidden directories resolve_fwd_refs dst package_opt
       parent_name_opt open_modules children input warnings_options
-      source_parent_file source_name source_cmt =
+      source_parent_file source_name cmt_filename_opt =
     let open Or_error in
     let resolver =
       Resolver.create ~important_digests:(not resolve_fwd_refs) ~directories
         ~open_modules
     in
-    let input = Fs.File.of_string input
-    and source_cmt =
-      match source_cmt with
-      | None -> None
-      | Some cmt -> Some (Fs.File.of_string cmt)
-    in
+    let input = Fs.File.of_string input in
     let output = output_file ~dst ~input in
     let parent_cli_spec =
       match (parent_name_opt, package_opt) with
@@ -193,39 +188,26 @@ end = struct
     in
     let source =
       match
-        (source_parent_file, source_name, source_cmt, Fs.File.get_ext input)
+        (source_parent_file, source_name)
       with
-      | Some parent, Some name, None, ".cmt" -> Ok (Some (parent, name, input))
-      | Some parent, Some name, Some cmt, ".cmt" ->
-          if Fpath.equal cmt input then Ok (Some (parent, name, input))
-          else
-            Error
-              (`Cli_error
-                "--cmt has to be equal to the input file when this one has \
-                 .cmt extension.")
-      | Some parent, Some name, Some cmt, _ -> Ok (Some (parent, name, cmt))
-      | Some _, Some _, None, _ ->
-          Error
-            (`Cli_error
-              "--cmt has to be passed when --source-parent-file and \
-               --source-name are passed and the input file is not a cmt file.")
-      | Some _, None, _, _ | None, Some _, _, _ ->
+      | Some parent, Some name -> Ok (Some (parent, name))
+      | Some _, None | None, Some _ ->
           Error
             (`Cli_error
               "--source-parent-file and --source-name must be passed at the \
                same time.")
-      | None, None, Some _, _ ->
-          Error
-            (`Cli_error
-              "--cmt should only be passed when --source-parent-file and \
-               --source-name are passed.")
-      | None, None, _, _ -> Ok None
+      | None, None -> Ok None
     in
+    begin
+      if Fs.File.get_ext input = ".cmt" && cmt_filename_opt <> None then
+        Error (`Cli_error "--cmt is redundant if the input is a cmt file")
+      else Ok ()
+    end >>= fun () ->
     parent_cli_spec >>= fun parent_cli_spec ->
     source >>= fun source ->
     Fs.Directory.mkdir_p (Fs.File.dirname output);
     Compile.compile ~resolver ~parent_cli_spec ~hidden ~children ~output
-      ~warnings_options ~source input
+      ~warnings_options ~source ~cmt_filename_opt input
 
   let input =
     let doc = "Input $(i,.cmti), $(i,.cmt), $(i,.cmi) or $(i,.mld) file." in