this repo has no description
1#if OCAML_VERSION >= (4, 14, 0)
2
3let rec is_persistent : Path.t -> bool = function
4 | Path.Pident id -> Ident_env.ident_is_global_or_predef id
5 | Path.Pdot(p, _) -> is_persistent p
6 | Path.Papply(p, _) -> is_persistent p
7#if OCAML_VERSION >= (5,1,0)
8 | Path.Pextra_ty (p, _) -> is_persistent p
9#endif
10
11let pos_of_loc (loc : Warnings.loc) = {
12 Odoc_model.Lang.Source_info.loc_start = {
13 pos_cnum = loc.loc_start.pos_cnum ;
14 pos_lnum = loc.loc_start.pos_lnum
15 } ;
16 loc_end = {
17 pos_cnum = loc.loc_end.pos_cnum ;
18 pos_lnum = loc.loc_end.pos_lnum
19 }
20}
21
22let counter =
23 let c = ref 0 in
24 fun () ->
25 incr c;
26 !c
27
28module Env = struct
29 open Typedtree
30 open Odoc_model.Paths
31
32 let rec structure env parent str =
33 let env' = Ident_env.add_structure_tree_items parent str env in
34 List.iter (structure_item env' parent) str.str_items
35
36 and signature env parent sg =
37 let env' = Ident_env.add_signature_tree_items parent sg env in
38 List.iter (signature_item env' parent) sg.sig_items
39
40 and signature_item env parent item =
41 match item.sig_desc with
42 | Tsig_module mb -> module_declaration env parent mb
43 | Tsig_recmodule mbs -> module_declarations env parent mbs
44 | Tsig_modtype mtd -> module_type_declaration env parent mtd
45 | Tsig_modtypesubst mtd -> module_type_declaration env parent mtd
46 | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_typext _
47 | Tsig_exception _ | Tsig_modsubst _ | Tsig_open _ | Tsig_include _
48 | Tsig_class _ | Tsig_class_type _ | Tsig_attribute _ ->
49 ()
50
51 and module_declaration env _parent md =
52 match md.md_id with
53 | None -> ()
54 | Some mb_id ->
55 let id = Ident_env.find_module_identifier env mb_id in
56 module_type env (id :> Identifier.Signature.t) md.md_type
57
58 and module_declarations env parent mds =
59 List.iter (module_declaration env parent) mds
60
61 and module_type_declaration env _parent mtd =
62 let id = Ident_env.find_module_type env mtd.mtd_id in
63 match mtd.mtd_type with
64 | None -> ()
65 | Some mty -> module_type env (id :> Identifier.Signature.t) mty
66
67 and structure_item env parent item =
68 match item.str_desc with
69 | Tstr_module mb -> module_binding env parent mb
70 | Tstr_recmodule mbs -> module_bindings env parent mbs
71 | Tstr_modtype mtd -> module_type_declaration env parent mtd
72 | Tstr_open _ | Tstr_value _ | Tstr_class _ | Tstr_eval _
73 | Tstr_class_type _ | Tstr_include _ | Tstr_attribute _ | Tstr_primitive _
74 | Tstr_type _ | Tstr_typext _ | Tstr_exception _ ->
75 ()
76
77 and module_type env (parent : Identifier.Signature.t) mty =
78 match mty.mty_desc with
79 | Tmty_signature sg -> signature env (parent : Identifier.Signature.t) sg
80 | Tmty_with (mty, _) -> module_type env parent mty
81 | Tmty_functor (_, t) -> module_type env parent t
82#if defined OXCAML
83 | Tmty_strengthen (t, _, _) -> module_type env parent t
84#endif
85 | Tmty_ident _ | Tmty_alias _ | Tmty_typeof _ -> ()
86
87 and module_bindings env parent mbs = List.iter (module_binding env parent) mbs
88
89 and module_binding env _parent mb =
90 match mb.mb_id with
91 | None -> ()
92 | Some id ->
93 let id = Ident_env.find_module_identifier env id in
94 let id = (id :> Identifier.Module.t) in
95 let inner =
96 match unwrap_module_expr_desc mb.mb_expr.mod_desc with
97 | Tmod_ident (_p, _) -> ()
98 | _ ->
99 let id = (id :> Identifier.Signature.t) in
100 module_expr env id mb.mb_expr
101 in
102 inner
103
104 and module_expr env parent mexpr =
105 match mexpr.mod_desc with
106 | Tmod_ident _ -> ()
107 | Tmod_structure str -> structure env parent str
108 | Tmod_functor (parameter, res) ->
109 let open Odoc_model.Names in
110 let env =
111 match parameter with
112 | Unit -> env
113 | Named (id_opt, _, arg) -> (
114 match id_opt with
115 | Some id ->
116 let env =
117 Ident_env.add_parameter parent id (ModuleName.of_ident id)
118 env
119 in
120 let id = Ident_env.find_module_identifier env id in
121 module_type env (id :> Identifier.Signature.t) arg;
122 env
123 | None -> env)
124 in
125 module_expr env (Odoc_model.Paths.Identifier.Mk.result parent) res
126 | Tmod_constraint (me, _, constr, _) ->
127 let () =
128 match constr with
129 | Tmodtype_implicit -> ()
130 | Tmodtype_explicit mt -> module_type env parent mt
131 in
132 module_expr env parent me
133 | _ -> ()
134
135 and unwrap_module_expr_desc = function
136 | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) ->
137 unwrap_module_expr_desc mexpr.mod_desc
138 | desc -> desc
139
140 let of_structure (id : Odoc_model.Paths.Identifier.RootModule.t)
141 (s : Typedtree.structure) =
142 let env = Ident_env.empty () in
143 let () = structure env (id :> Odoc_model.Paths.Identifier.Signature.t) s in
144 env
145end
146
147module LocHashtbl = Hashtbl.Make (struct
148 type t = Location.t
149 let equal l1 l2 = l1 = l2
150 let hash = Hashtbl.hash
151end)
152
153module IdentHashtbl = Hashtbl.Make (struct
154 type t = Ident.t
155 let equal l1 l2 = l1 = l2
156 let hash = Hashtbl.hash
157end)
158
159module AnnotHashtbl = Hashtbl.Make (struct
160 type t =
161 Odoc_model.Lang.Source_info.annotation Odoc_model.Lang.Source_info.with_pos
162 let equal l1 l2 = l1 = l2
163 let hash = Hashtbl.hash
164end)
165
166module UidHashtbl = Shape.Uid.Tbl
167
168(* Adds the local definitions found in traverse infos to the [loc_to_id] and
169 [ident_to_id] tables. *)
170let populate_local_defs source_id poses loc_to_id local_ident_to_loc =
171 List.iter
172 (function
173 | Typedtree_traverse.Analysis.LocalDefinition id, loc ->
174 let name =
175 Odoc_model.Names.LocalName.make_std
176 (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ()))
177 in
178 let identifier =
179 Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name)
180 in
181 LocHashtbl.add loc_to_id loc identifier;
182 IdentHashtbl.add local_ident_to_loc id loc
183 | Typedtree_traverse.Analysis.GlobalDefinition id, loc ->
184 (* Track ident→loc for same-module reference resolution.
185 The loc→id mapping is handled by populate_global_defs. *)
186 IdentHashtbl.add local_ident_to_loc id loc
187 | _ -> ())
188 poses
189
190(* In order to turn an identifier into a source identifier, we need to generate
191 a unique anchor for any identifier. *)
192let anchor_of_identifier id =
193 let open Odoc_document.Url in
194 let open Odoc_model.Paths in
195 let open Odoc_model.Names in
196 let rec anchor_of_identifier acc (id : Identifier.t) =
197 let continue anchor parent =
198 anchor_of_identifier (anchor :: acc) (parent :> Identifier.t)
199 in
200 let anchor kind name =
201 Printf.sprintf "%s-%s" (Anchor.string_of_kind kind) name
202 in
203 match id.iv with
204 | `InstanceVariable (parent, name) ->
205 let anchor = anchor `Val (InstanceVariableName.to_string name) in
206 continue anchor parent
207 | `Parameter (parent, name) as iv ->
208 let arg_num =
209 Identifier.FunctorParameter.functor_arg_pos { id with iv }
210 in
211 let kind = `Parameter arg_num in
212 let anchor = anchor kind (ModuleName.to_string name) in
213 continue anchor parent
214 | `Module (parent, name) ->
215 let anchor = anchor `Module (ModuleName.to_string name) in
216 continue anchor parent
217 | `ModuleType (parent, name) ->
218 let anchor = anchor `ModuleType (ModuleTypeName.to_string name) in
219 continue anchor parent
220 | `Method (parent, name) ->
221 let anchor = anchor `Method (MethodName.to_string name) in
222 continue anchor parent
223 | `AssetFile _ -> assert false
224 | `Field (parent, name) ->
225 let anchor = anchor `Field (FieldName.to_string name) in
226 continue anchor parent
227 | `UnboxedField (parent, name) ->
228 let anchor = anchor `UnboxedField (UnboxedFieldName.to_string name) in
229 continue anchor parent
230 | `SourceLocationMod _ -> assert false
231 | `Result parent -> anchor_of_identifier acc (parent :> Identifier.t)
232 | `SourceLocationInternal _ -> assert false
233 | `Type (parent, name) ->
234 let anchor = anchor `Type (TypeName.to_string name) in
235 continue anchor parent
236 | `Label _ -> assert false
237 | `Exception (parent, name) ->
238 let anchor = anchor `Exception (ExceptionName.to_string name) in
239 continue anchor parent
240 | `Class (parent, name) ->
241 let anchor = anchor `Class (TypeName.to_string name) in
242 continue anchor parent
243 | `Page _ -> assert false
244 | `LeafPage _ -> assert false
245 | `SourceLocation _ -> assert false
246 | `ClassType (parent, name) ->
247 let anchor = anchor `ClassType (TypeName.to_string name) in
248 continue anchor parent
249 | `SourcePage _ -> assert false
250 | `Value (parent, name) ->
251 let anchor = anchor `Val (ValueName.to_string name) in
252 continue anchor parent
253 | `Constructor (parent, name) ->
254 let anchor = anchor `Constructor (ConstructorName.to_string name) in
255 continue anchor parent
256 | `Root _ ->
257 (* We do not need to include the "container" root module in the anchor
258 to have unique anchors. *)
259 acc
260 | `Extension (parent, name) ->
261 let anchor = anchor `Extension (ExtensionName.to_string name) in
262 continue anchor parent
263 | `ExtensionDecl (parent, name, _) ->
264 let anchor = anchor `ExtensionDecl (ExtensionName.to_string name) in
265 continue anchor parent
266 in
267 anchor_of_identifier [] id |> String.concat "."
268
269(* Adds the global definitions, found in the [uid_to_loc], to the [loc_to_id]
270 and [uid_to_id] tables. *)
271let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id =
272 let mk_src_id id =
273 let name = Odoc_model.Names.DefName.make_std (anchor_of_identifier id) in
274 (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name)
275 :> Odoc_model.Paths.Identifier.SourceLocation.t)
276 in
277 let () =
278 Ident_env.iter_located_identifier env @@ fun loc id ->
279 LocHashtbl.add loc_to_id loc (mk_src_id id)
280 in
281 let mk_src_id () =
282 let name =
283 Odoc_model.Names.DefName.make_std (Printf.sprintf "def_%d" (counter ()))
284 in
285 (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name)
286 :> Odoc_model.Paths.Identifier.SourceLocation.t)
287 in
288 Shape.Uid.Tbl.iter
289 (fun uid loc ->
290 if loc.Location.loc_ghost then ()
291 else
292 match LocHashtbl.find_opt loc_to_id loc with
293 | Some id -> UidHashtbl.add uid_to_id uid id
294 | None -> (
295 (* In case there is no entry for the location of the uid, we add one. *)
296 match uid with
297 | Item _ ->
298 let id = mk_src_id () in
299 LocHashtbl.add loc_to_id loc id;
300 UidHashtbl.add uid_to_id uid id
301 | Compilation_unit _ -> ()
302 | _ -> ()))
303 uid_to_loc
304
305(* Extract [Typedtree_traverse] occurrence information and turn them into proper
306 source infos *)
307let rec read_module_path_fallback ~root p =
308 let open Odoc_model.Names in
309 match (p : Path.t) with
310 | Pident id -> `Dot (`Root (ModuleName.make_std root), ModuleName.make_std (Ident.name id))
311 | Pdot (p, s) -> `Dot (read_module_path_fallback ~root p, ModuleName.make_std s)
312 | Papply (p, arg) -> `Apply (read_module_path_fallback ~root p, read_module_path_fallback ~root arg)
313#if OCAML_VERSION >= (5,1,0)
314 | Pextra_ty _ -> assert false
315#endif
316
317let process_occurrences ~module_name env poses loc_to_id local_ident_to_loc =
318 let open Odoc_model.Lang.Source_info in
319 (* Ensure source infos are not repeated by putting them in a Set (a unit hashtbl) *)
320 let occ_tbl = AnnotHashtbl.create 100 in
321 let fallback_read_value p =
322 let open Odoc_model.Names in
323 match (p : Path.t) with
324 | Pdot (parent, s) -> Some (`DotV (read_module_path_fallback ~root:module_name parent, ValueName.make_std s))
325 | _ -> None
326 in
327 let fallback_read_module p =
328 Some (read_module_path_fallback ~root:module_name p)
329 in
330 let fallback_read_module_type p =
331 let open Odoc_model.Names in
332 match (p : Path.t) with
333 | Pdot (parent, s) -> Some (`DotMT (read_module_path_fallback ~root:module_name parent, ModuleTypeName.make_std s))
334 | _ -> None
335 in
336 let fallback_read_type p =
337 let open Odoc_model.Names in
338 match (p : Path.t) with
339 | Pdot (parent, s) -> Some (`DotT (read_module_path_fallback ~root:module_name parent, TypeName.make_std s))
340 | _ -> None
341 in
342 let process p find_in_env fallback =
343 match p with
344 | Path.Pident id when IdentHashtbl.mem local_ident_to_loc id -> (
345 match
346 LocHashtbl.find_opt loc_to_id
347 (IdentHashtbl.find local_ident_to_loc id)
348 with
349 | None -> None
350 | Some id ->
351 let documentation = None and implementation = Some (Resolved id) in
352 Some { documentation; implementation })
353 | p -> (
354 match find_in_env env p with
355 | path ->
356 let documentation = if is_persistent p then Some path else None
357 and implementation = Some (Unresolved path) in
358 Some { documentation; implementation }
359 | exception _ ->
360 if not (is_persistent p) then
361 match fallback p with
362 | Some path ->
363 let documentation = None
364 and implementation = Some (Unresolved path) in
365 Some { documentation; implementation }
366 | None -> None
367 else None)
368 in
369 List.iter
370 (function
371 | Typedtree_traverse.Analysis.Value p, loc ->
372 process p Ident_env.Path.read_value fallback_read_value
373 |> Option.iter @@ fun l ->
374 AnnotHashtbl.replace occ_tbl (Value l, pos_of_loc loc) ()
375 | Module p, loc ->
376 process p Ident_env.Path.read_module fallback_read_module
377 |> Option.iter @@ fun l ->
378 AnnotHashtbl.replace occ_tbl (Module l, pos_of_loc loc) ()
379 | ModuleType p, loc ->
380 process p Ident_env.Path.read_module_type fallback_read_module_type
381 |> Option.iter @@ fun l ->
382 AnnotHashtbl.replace occ_tbl (ModuleType l, pos_of_loc loc) ()
383 | Type p, loc ->
384 process p Ident_env.Path.read_type fallback_read_type
385 |> Option.iter @@ fun l ->
386 AnnotHashtbl.replace occ_tbl (Type l, pos_of_loc loc) ()
387 | LocalDefinition _, _ | GlobalDefinition _, _ -> ())
388 poses;
389 AnnotHashtbl.fold (fun k () acc -> k :: acc) occ_tbl []
390
391(* Add definition source info from the [loc_to_id] table *)
392let add_definitions loc_to_id occurrences =
393 LocHashtbl.fold
394 (fun loc id acc ->
395 (Odoc_model.Lang.Source_info.Definition id, pos_of_loc loc) :: acc)
396 loc_to_id occurrences
397
398let read_cmt_infos source_id shape_info impl digest root imports =
399 match shape_info with
400 | Some (shape, uid_to_loc) ->
401 let fake_root_id =
402 Odoc_model.Paths.Identifier.Mk.root
403 (None, Odoc_model.Names.ModuleName.make_std "fake_root")
404 in
405 let env = Env.of_structure fake_root_id impl in
406 let traverse_infos =
407 Typedtree_traverse.of_cmt env impl |> List.rev
408 (* Information are accumulated in a list. We need to have the
409 first info first in the list, to assign anchors with increasing
410 numbers, so that adding some content at the end of a file does
411 not modify the anchors for existing anchors. *)
412 in
413 let loc_to_id = LocHashtbl.create 10
414 and local_ident_to_loc = IdentHashtbl.create 10
415 and uid_to_id = UidHashtbl.create 10 in
416 let () =
417 match source_id with
418 | None -> ()
419 | Some source_id ->
420 populate_local_defs source_id traverse_infos loc_to_id
421 local_ident_to_loc;
422 populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id
423 in
424 let module_name =
425 Odoc_model.Root.Odoc_file.name root.Odoc_model.Root.file
426 in
427 let source_infos =
428 process_occurrences ~module_name env traverse_infos loc_to_id
429 local_ident_to_loc
430 |> add_definitions loc_to_id
431 in
432 let shape_info = Some (shape, Shape.Uid.Tbl.to_map uid_to_id) in
433 {
434 Odoc_model.Lang.Implementation.id = source_id;
435 source_info = source_infos;
436 digest;
437 root;
438 linked = false;
439 shape_info;
440 imports;
441 }
442 | None as shape_info ->
443 {
444 Odoc_model.Lang.Implementation.id = source_id;
445 source_info = [];
446 digest;
447 root;
448 linked = false;
449 shape_info;
450 imports;
451 }
452
453
454#else
455
456let read_cmt_infos source_id shape_info _impl digest root imports =
457 {
458 Odoc_model.Lang.Implementation.id = source_id;
459 source_info = [];
460 digest;
461 root;
462 linked = false;
463 shape_info;
464 imports;
465 }
466
467#endif