jon.recoil.org
this repo has no description
1(*
2 * Copyright (c) 2014 Leo White <lpw25@cl.cam.ac.uk>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16
17open Odoc_model
18open Names
19
20module Id = Paths.Identifier
21module P = Paths.Path
22
23module LocHashtbl = Hashtbl.Make(struct
24 type t = Location.t
25 let equal l1 l2 = l1 = l2
26 let hash = Hashtbl.hash
27 end)
28
29type t =
30 { modules : Id.Module.t Ident.tbl;
31 parameters : Id.FunctorParameter.t Ident.tbl;
32 module_paths : P.Module.t Ident.tbl;
33 module_types : Id.ModuleType.t Ident.tbl;
34 types : Id.DataType.t Ident.tbl;
35 exceptions: Id.Exception.t Ident.tbl;
36 extensions: Id.Extension.t Ident.tbl;
37 constructors: Id.Constructor.t Ident.tbl;
38 values: Id.Value.t Ident.tbl;
39 classes : Id.Class.t Ident.tbl;
40 class_types : Id.ClassType.t Ident.tbl;
41 loc_to_ident : Id.t LocHashtbl.t;
42 shadowed : Ident.t list;
43 }
44
45let empty () =
46 { modules = Ident.empty;
47 parameters = Ident.empty;
48 module_paths = Ident.empty;
49 module_types = Ident.empty;
50 types = Ident.empty;
51 exceptions = Ident.empty;
52 constructors = Ident.empty;
53 extensions = Ident.empty;
54 values = Ident.empty;
55 classes = Ident.empty;
56 class_types = Ident.empty;
57 loc_to_ident = LocHashtbl.create 100;
58 shadowed = [];
59 }
60
61(* The boolean is an override for whether it should be hidden - true only for
62 items introduced by extended open *)
63type item = [
64 `Module of Ident.t * bool * Location.t option
65 | `ModuleType of Ident.t * bool * Location.t option
66 | `Type of Ident.t * bool * Location.t option
67 | `Constructor of Ident.t * Ident.t * Location.t option
68 (* Second ident.t is for the type parent *)
69 | `Value of Ident.t * bool * Location.t option
70 | `Class of Ident.t * Ident.t * Ident.t * Ident.t option * bool * Location.t option
71 | `ClassType of Ident.t * Ident.t * Ident.t option * bool * Location.t option
72 | `Exception of Ident.t * Location.t option
73 (* Exceptions needs to be added to the [loc_to_ident] table. *)
74 | `Extension of Ident.t * Location.t option
75 (* Extension constructor also need to be added to the [loc_to_ident] table,
76 since they get an entry in the [uid_to_loc] table. *)
77]
78
79type items =
80 [ item
81 | `Include of item list
82]
83
84let extract_visibility =
85 let open Compat in
86 function
87 | Sig_type (_, _, _, vis)
88 | Sig_module (_, _, _, _, vis)
89 | Sig_modtype (_, _, vis)
90 | Sig_value (_, _, vis)
91 | Sig_class (_, _, _, vis)
92 | Sig_class_type (_, _, _, vis)
93 | Sig_typext (_, _, _, vis) ->
94 vis
95
96let rec extract_signature_type_items vis items =
97 let open Compat in
98 match items with
99 | item :: rest ->
100 let vis' = extract_visibility item in
101 if vis = vis' then
102 let hidden = vis' = Hidden in
103 extract_signature_type_items_extract vis ~hidden item rest
104 else
105 extract_signature_type_items_skip vis item rest
106 | [] -> []
107
108and extract_signature_type_items_extract vis ~hidden item rest =
109 let open Compat in
110 match item, rest with
111 | Sig_type(id, td, _, _), _ ->
112 if Btype.is_row_name (Ident.name id)
113 then extract_signature_type_items vis rest
114 else
115 let constrs = match td.type_kind with
116#if OCAML_VERSION < (5,2,0)
117 | Types.Type_abstract -> []
118#else
119 | Types.Type_abstract _ -> []
120#endif
121#if defined OXCAML
122 | Type_record (_, _, _) -> []
123 | Type_record_unboxed_product (_, _, _) -> []
124#else
125 | Type_record (_, _) -> []
126#endif
127#if OCAML_VERSION < (4,13,0)
128 | Type_variant cstrs ->
129#elif defined OXCAML
130 | Type_variant (cstrs, _, _) ->
131#else
132 | Type_variant (cstrs, _) ->
133#endif
134 List.map (fun c -> `Constructor (c.Types.cd_id, id, Some c.cd_loc)) cstrs
135 | Type_open -> [] in
136 `Type (id, hidden, None) :: constrs @ extract_signature_type_items vis rest
137
138 | Sig_module(id, _, _, _, _), _ ->
139 `Module (id, hidden, None) :: extract_signature_type_items vis rest
140
141 | Sig_modtype(id, _, _), _ ->
142 `ModuleType (id, hidden, None) :: extract_signature_type_items vis rest
143
144 | Sig_value(id, _, _), _ ->
145 `Value (id, hidden, None) :: extract_signature_type_items vis rest
146#if OCAML_VERSION < (5,1,0)
147 | Sig_class(id, _, _, _),
148 Sig_class_type(ty_id, _, _, _)
149 :: Sig_type(obj_id, _, _, _)
150 :: Sig_type(cl_id, _, _, _) :: _ ->
151 `Class (id, ty_id, obj_id, Some cl_id, hidden, None)
152 :: extract_signature_type_items vis rest
153
154 | Sig_class_type(id, _, _, _),
155 Sig_type(obj_id, _, _, _) :: Sig_type(cl_id, _, _, _) :: _ ->
156 `ClassType (id, obj_id, Some cl_id, hidden, None)
157 :: extract_signature_type_items vis rest
158#else
159 | Sig_class(id, _, _, _),
160 Sig_class_type(ty_id, _, _, _) :: Sig_type(obj_id, _, _, _) :: _ ->
161 `Class (id, ty_id, obj_id, None, hidden, None)
162 :: extract_signature_type_items vis rest
163
164 | Sig_class_type(id, _, _, _), Sig_type(obj_id, _, _, _) :: _ ->
165 `ClassType (id, obj_id, None, hidden, None)
166 :: extract_signature_type_items vis rest
167#endif
168
169 | Sig_typext (id, constr, Text_exception, _), _ ->
170 `Exception (id, Some constr.ext_loc)
171 :: extract_signature_type_items vis rest
172
173 | Sig_typext (id, constr, _, _), _ ->
174 `Extension (id, Some constr.ext_loc)
175 :: extract_signature_type_items vis rest
176
177 | Sig_class _, _
178 | Sig_class_type _, _ -> assert false
179
180and extract_signature_type_items_skip vis item rest =
181 let open Compat in
182 match item, rest with
183 | Sig_class_type _, Sig_type _ :: Sig_type _ :: rest
184 | Sig_class _, Sig_class_type _ :: Sig_type _ :: Sig_type _ :: rest
185 | Sig_typext _, rest
186 | Sig_modtype _, rest
187 | Sig_module _, rest
188 | Sig_type _, rest
189 | Sig_value _, rest ->
190 extract_signature_type_items vis rest
191
192 | Sig_class _, _
193 | Sig_class_type _, _ -> assert false
194
195#if OCAML_VERSION >= (4,8,0)
196
197let extract_extended_open o =
198 let open Typedtree in
199 extract_signature_type_items Hidden (Compat.signature o.open_bound_items)
200#endif
201
202
203let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> items list = fun hide_item items ->
204 let open Typedtree in
205 match items with
206#if OCAML_VERSION < (4,3,0)
207 | { sig_desc = Tsig_type decls; _} :: rest ->
208#else
209 | { sig_desc = Tsig_type (_, decls); _} :: rest ->
210#endif
211 Odoc_utils.List.concat_map (fun decl ->
212 if Btype.is_row_name (Ident.name decl.typ_id)
213 then []
214 else
215 `Type (decl.typ_id, hide_item, Some decl.typ_loc) ::
216 match decl.typ_kind with
217 Ttype_abstract -> []
218 | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs
219 | Ttype_record _ -> []
220#if defined OXCAML
221 | Ttype_record_unboxed_product _ -> []
222#endif
223 | Ttype_open -> []
224 )
225 decls @ extract_signature_tree_items hide_item rest
226
227#if OCAML_VERSION < (4,8,0)
228 | { sig_desc = Tsig_exception tyexn_constructor; _ } :: rest ->
229#else
230 | { sig_desc = Tsig_exception { tyexn_constructor; _ }; _ } :: rest ->
231#endif
232 `Exception (tyexn_constructor.ext_id, Some tyexn_constructor.ext_loc) :: extract_signature_tree_items hide_item rest
233
234 | { sig_desc = Tsig_typext { tyext_constructors; _ }; _} :: rest ->
235 let x = List.map (fun { ext_id; ext_loc; _ } -> `Extension (ext_id, Some ext_loc)) tyext_constructors in
236 x @ extract_signature_tree_items hide_item rest
237
238
239#if OCAML_VERSION >= (4,10,0)
240 | { sig_desc = Tsig_module { md_id = Some id; _ }; sig_loc; _} :: rest ->
241 [`Module (id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest
242 | { sig_desc = Tsig_module _; _ } :: rest ->
243 extract_signature_tree_items hide_item rest
244 | { sig_desc = Tsig_recmodule mds; _} :: rest ->
245 List.fold_right (
246 fun md items ->
247 match md.md_id with
248 | Some id -> `Module (id, hide_item, Some md.md_loc) :: items
249 | None -> items)
250 mds [] @ extract_signature_tree_items hide_item rest
251#else
252 | { sig_desc = Tsig_module{ md_id; _}; _} :: rest ->
253 [`Module (md_id, hide_item, None)] @ extract_signature_tree_items hide_item rest
254 | { sig_desc = Tsig_recmodule mds; _ } :: rest ->
255 List.map (fun md -> `Module (md.md_id, hide_item, None))
256 mds @ extract_signature_tree_items hide_item rest
257#endif
258 | { sig_desc = Tsig_value {val_id; _}; sig_loc; _ } :: rest->
259 [`Value (val_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest
260 | { sig_desc = Tsig_modtype mtd; sig_loc; _} :: rest ->
261 [`ModuleType (mtd.mtd_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest
262#if defined OXCAML
263 | {sig_desc = Tsig_include (incl, _); _ } :: rest ->
264#else
265 | {sig_desc = Tsig_include incl; _ } :: rest ->
266#endif
267 [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest
268 | {sig_desc = Tsig_attribute attr; _ } :: rest ->
269 let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in
270 extract_signature_tree_items hide_item rest
271 | {sig_desc = Tsig_class cls; _} :: rest ->
272 List.map
273 (fun cld ->
274 let typehash =
275#if OCAML_VERSION < (4,4,0)
276 Some cld.ci_id_typesharp
277#elif OCAML_VERSION < (5,1,0)
278 Some cld.ci_id_typehash
279#else
280 None
281#endif
282 in
283 `Class (cld.ci_id_class, cld.ci_id_class_type, cld.ci_id_object, typehash, hide_item, Some cld.ci_id_name.loc))
284 cls @ extract_signature_tree_items hide_item rest
285 | { sig_desc = Tsig_class_type cltyps; _ } :: rest ->
286 List.map
287 (fun clty ->
288 let typehash =
289#if OCAML_VERSION < (4,4,0)
290 Some clty.ci_id_typesharp
291#elif OCAML_VERSION < (5,1,0)
292 Some clty.ci_id_typehash
293#else
294 None
295#endif
296 in
297
298 `ClassType (clty.ci_id_class_type, clty.ci_id_object, typehash, hide_item, Some clty.ci_id_name.loc))
299 cltyps @ extract_signature_tree_items hide_item rest
300#if OCAML_VERSION >= (4,8,0)
301 | { sig_desc = Tsig_modsubst ms; sig_loc; _ } :: rest ->
302 [`Module (ms.ms_id, hide_item, Some sig_loc )] @ extract_signature_tree_items hide_item rest
303 | { sig_desc = Tsig_typesubst ts; sig_loc; _} :: rest ->
304 List.map (fun decl -> `Type (decl.typ_id, hide_item, Some sig_loc))
305 ts @ extract_signature_tree_items hide_item rest
306#endif
307#if OCAML_VERSION >= (4,13,0)
308 | { sig_desc = Tsig_modtypesubst mtd; sig_loc; _ } :: rest ->
309 [`ModuleType (mtd.mtd_id, hide_item, Some sig_loc)] @ extract_signature_tree_items hide_item rest
310#endif
311 | { sig_desc = Tsig_open _;_} :: rest -> extract_signature_tree_items hide_item rest
312 | [] -> []
313
314let rec read_pattern hide_item pat =
315 let open Typedtree in
316 match pat.pat_desc with
317#if OCAML_VERSION < (5,2,0)
318 | Tpat_var(id, loc) ->
319#elif defined OXCAML
320 | Tpat_var(id, loc, _, _, _) ->
321#else
322 | Tpat_var(id, loc, _) ->
323#endif
324 [`Value(id, hide_item, Some loc.loc)]
325#if OCAML_VERSION < (5,2,0)
326 | Tpat_alias(pat, id, loc) ->
327#elif defined OXCAML
328 | Tpat_alias(pat, id, loc, _, _, _, _) ->
329#elif OCAML_VERSION < (5,4,0)
330 | Tpat_alias(pat, id, loc, _) ->
331#else
332 | Tpat_alias(pat, id, loc, _, _) ->
333#endif
334 `Value(id, hide_item, Some loc.loc) :: read_pattern hide_item pat
335 | Tpat_record(pats, _) ->
336 List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats)
337#if defined OXCAML
338 | Tpat_record_unboxed_product(pats, _) ->
339 List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats)
340#endif
341#if OCAML_VERSION < (4,13,0)
342 | Tpat_construct(_, _, pats)
343#else
344 | Tpat_construct(_, _, pats, _)
345#endif
346#if defined OXCAML
347 | Tpat_array (_, _, pats) ->
348 List.concat (List.map (fun pat -> read_pattern hide_item pat) pats)
349#elif OCAML_VERSION < (5,4,0)
350 | Tpat_array pats ->
351 List.concat (List.map (fun pat -> read_pattern hide_item pat) pats)
352#else
353 | Tpat_array (_,pats) ->
354 List.concat (List.map (fun pat -> read_pattern hide_item pat) pats)
355#endif
356 | Tpat_tuple pats ->
357#if OCAML_VERSION >= (5,4,0) || defined OXCAML
358 List.concat (List.map (fun (_lbl,pat) -> read_pattern hide_item pat) pats)
359#else
360 List.concat (List.map (fun pat -> read_pattern hide_item pat) pats)
361#endif
362#if defined OXCAML
363 | Tpat_unboxed_tuple pats ->
364 List.concat (List.map (fun (_, pat, _) -> read_pattern hide_item pat) pats)
365#endif
366 | Tpat_or(pat, _, _)
367 | Tpat_variant(_, Some pat, _)
368 | Tpat_lazy pat -> read_pattern hide_item pat
369 | Tpat_any | Tpat_constant _ | Tpat_variant(_, None, _) -> []
370#if OCAML_VERSION >= (4,8,0) && OCAML_VERSION < (4,11,0)
371 | Tpat_exception pat -> read_pattern hide_item pat
372#endif
373
374let rec extract_structure_tree_items : bool -> Typedtree.structure_item list -> items list = fun hide_item items ->
375 let open Typedtree in
376 match items with
377#if OCAML_VERSION < (4,3,0)
378 | { str_desc = Tstr_type decls; _ } :: rest ->
379#else
380 | { str_desc = Tstr_type (_, decls); _ } :: rest -> (* TODO: handle rec_flag *)
381#endif
382 Odoc_utils.List.concat_map (fun decl ->
383 `Type (decl.typ_id, hide_item, Some decl.typ_loc) ::
384 (match decl.typ_kind with
385 Ttype_abstract -> []
386 | Ttype_variant constrs -> List.map (fun c -> `Constructor (c.cd_id, decl.typ_id, Some c.cd_loc)) constrs
387 | Ttype_record _ -> []
388#if defined OXCAML
389 | Ttype_record_unboxed_product _ -> []
390#endif
391 | Ttype_open -> []
392 ))
393 decls @ extract_structure_tree_items hide_item rest
394
395#if OCAML_VERSION < (4,8,0)
396 | { str_desc = Tstr_exception tyexn_constructor; _ } :: rest ->
397#else
398 | { str_desc = Tstr_exception { tyexn_constructor; _ }; _ } :: rest ->
399#endif
400 `Exception (tyexn_constructor.ext_id, Some tyexn_constructor.ext_loc) :: extract_structure_tree_items hide_item rest
401
402 | { str_desc = Tstr_typext { tyext_constructors; _ }; _} :: rest ->
403 let x = List.map (fun { ext_id; ext_loc; _ } -> `Extension (ext_id, Some ext_loc)) tyext_constructors in
404 x @ extract_structure_tree_items hide_item rest
405
406#if OCAML_VERSION < (4,3,0)
407 | { str_desc = Tstr_value (_, vbs ); _} :: rest ->
408#else
409 | { str_desc = Tstr_value (_, vbs); _ } :: rest -> (*TODO: handle rec_flag *)
410#endif
411 ( List.map (fun vb -> read_pattern hide_item vb.vb_pat) vbs
412 |> List.flatten) @ extract_structure_tree_items hide_item rest
413
414#if OCAML_VERSION >= (4,10,0)
415 | { str_desc = Tstr_module { mb_id = Some id; mb_loc; _}; _} :: rest ->
416 [`Module (id, hide_item, Some mb_loc)] @ extract_structure_tree_items hide_item rest
417 | { str_desc = Tstr_module _; _} :: rest -> extract_structure_tree_items hide_item rest
418 | { str_desc = Tstr_recmodule mbs; _ } :: rest ->
419 List.fold_right
420 (fun mb items ->
421 match mb.mb_id with
422 | Some id -> `Module (id, hide_item, Some mb.mb_loc) :: items
423 | None -> items) mbs [] @ extract_structure_tree_items hide_item rest
424#else
425 | { str_desc = Tstr_module { mb_id; mb_loc; _}; _} :: rest ->
426 [`Module (mb_id, hide_item, Some mb_loc)] @ extract_structure_tree_items hide_item rest
427 | { str_desc = Tstr_recmodule mbs; _} :: rest ->
428 List.map (fun mb -> `Module (mb.mb_id, hide_item, None))
429 mbs @ extract_structure_tree_items hide_item rest
430#endif
431 | { str_desc = Tstr_modtype mtd; str_loc; _} :: rest ->
432 [`ModuleType (mtd.mtd_id, hide_item, Some str_loc)] @ extract_structure_tree_items hide_item rest
433 | { str_desc = Tstr_include incl; _ } :: rest ->
434 [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_structure_tree_items hide_item rest
435 | { str_desc = Tstr_attribute attr; _} :: rest ->
436 let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in
437 extract_structure_tree_items hide_item rest
438 | { str_desc = Tstr_class cls; _ } :: rest ->
439 List.map
440#if OCAML_VERSION < (4,3,0)
441 (fun (cld, _, _) ->
442#else
443 (fun (cld, _) ->
444#endif
445 `Class (cld.ci_id_class,
446 cld.ci_id_class_type, cld.ci_id_object,
447#if OCAML_VERSION < (4,4,0)
448 Some cld.ci_id_typesharp,
449#elif OCAML_VERSION < (5,1,0)
450 Some cld.ci_id_typehash,
451#else
452 None,
453#endif
454 hide_item, Some cld.ci_id_name.loc
455 )) cls @ extract_structure_tree_items hide_item rest
456 | {str_desc = Tstr_class_type cltyps; _ } :: rest ->
457 List.map
458 (fun (_, _, clty) ->
459 `ClassType (clty.ci_id_class_type,
460 clty.ci_id_object,
461#if OCAML_VERSION < (4,4,0)
462 Some clty.ci_id_typesharp,
463#elif OCAML_VERSION < (5,1,0)
464 Some clty.ci_id_typehash,
465#else
466 None,
467#endif
468 hide_item, Some clty.ci_id_name.loc
469 )) cltyps @ extract_structure_tree_items hide_item rest
470#if OCAML_VERSION < (4,8,0)
471 | { str_desc = Tstr_open _; _} :: rest -> extract_structure_tree_items hide_item rest
472#else
473 | { str_desc = Tstr_open o; _ } :: rest ->
474 ((extract_extended_open o) :> items list) @ extract_structure_tree_items hide_item rest
475#endif
476 | { str_desc = Tstr_primitive {val_id; _}; str_loc; _ } :: rest ->
477 [`Value (val_id, false, Some str_loc)] @ extract_structure_tree_items hide_item rest
478 | { str_desc = Tstr_eval _; _} :: rest -> extract_structure_tree_items hide_item rest
479 | [] -> []
480
481
482let flatten_includes : items list -> item list = fun items ->
483 List.map (function
484 | `Type _
485 | `Constructor _
486 | `Module _
487 | `ModuleType _
488 | `Value _
489 | `Class _
490 | `Exception _
491 | `Extension _
492 | `ClassType _ as x -> [x]
493 | `Include xs -> xs) items |> List.flatten
494
495let type_name_exists name items =
496 List.exists (function | `Type (id', _, _) when Ident.name id' = name -> true | _ -> false) items
497
498let value_name_exists name items =
499 List.exists (function | `Value (id', _, _) when Ident.name id' = name -> true | _ -> false) items
500
501let module_name_exists name items =
502 List.exists (function | `Module (id', _, _) when Ident.name id' = name -> true | _ -> false) items
503
504let module_type_name_exists name items =
505 List.exists (function | `ModuleType (id', _, _) when Ident.name id' = name -> true | _ -> false) items
506
507let class_name_exists name items =
508 List.exists (function | `Class (id',_,_,_,_,_) when Ident.name id' = name -> true | _ -> false) items
509
510let class_type_name_exists name items =
511 List.exists (function | `ClassType (id',_,_,_,_) when Ident.name id' = name -> true | _ -> false) items
512
513let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env ->
514 let open Odoc_model.Paths.Identifier in
515 let rec inner items env =
516 match items with
517 | `Type (t, is_hidden_item, loc) :: rest ->
518 let name = Ident.name t in
519 let is_shadowed = type_name_exists name rest in
520 let identifier, shadowed =
521 if is_shadowed
522 then Mk.type_(parent, TypeName.shadowed_of_string name), t :: env.shadowed
523 else Mk.type_(parent, (if is_hidden_item then TypeName.hidden_of_string else TypeName.make_std) name), env.shadowed
524 in
525 let types = Ident.add t identifier env.types in
526 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
527 inner rest { env with types; shadowed }
528
529 | `Constructor (t, t_parent, loc) :: rest ->
530 let name = Ident.name t in
531 let identifier =
532 let parent = Ident.find_same t_parent env.types in
533 Mk.constructor(parent, ConstructorName.make_std name)
534 in
535 let constructors = Ident.add t identifier env.constructors in
536 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
537 inner rest { env with constructors }
538
539 | `Exception (t, loc) :: rest ->
540 let name = Ident.name t in
541 let identifier = Mk.exception_(parent, ExceptionName.make_std name) in
542 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
543 let exceptions = Ident.add t identifier env.exceptions in
544 inner rest {env with exceptions }
545
546 | `Extension (t, loc) :: rest ->
547 let name = Ident.name t in
548 let identifier = Mk.extension(parent, ExtensionName.make_std name) in
549 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
550 let extensions = Ident.add t identifier env.extensions in
551 inner rest {env with extensions }
552
553 | `Value (t, is_hidden_item, loc) :: rest ->
554 let name = Ident.name t in
555 let is_shadowed = value_name_exists name rest in
556 let identifier, shadowed =
557 if is_shadowed
558 then Mk.value(parent, ValueName.shadowed_of_string name), t :: env.shadowed
559 else Mk.value(parent, (if is_hidden_item then ValueName.hidden_of_string else ValueName.make_std) name), env.shadowed
560 in
561 let values = Ident.add t identifier env.values in
562 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
563 inner rest { env with values; shadowed }
564
565 | `ModuleType (t, is_hidden_item, loc) :: rest ->
566 let name = Ident.name t in
567 let is_shadowed = module_type_name_exists name rest in
568 let identifier, shadowed =
569 if is_shadowed
570 then Mk.module_type(parent, ModuleTypeName.shadowed_of_string name), t :: env.shadowed
571 else Mk.module_type(parent,(if is_hidden_item then ModuleTypeName.hidden_of_string else ModuleTypeName.make_std) name), env.shadowed
572 in
573 let module_types = Ident.add t identifier env.module_types in
574 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
575 inner rest { env with module_types; shadowed }
576
577 | `Module (t, is_hidden_item, loc) :: rest ->
578 let name = Ident.name t in
579 let is_shadowed = module_name_exists name rest in
580 let identifier, shadowed =
581 if is_shadowed
582 then Mk.module_(parent, ModuleName.shadowed_of_string name), t :: env.shadowed
583 else Mk.module_(parent, (if is_hidden_item then ModuleName.hidden_of_string else ModuleName.make_std) name), env.shadowed
584 in
585 let path = `Identifier(identifier, is_hidden_item || is_shadowed) in
586 let modules = Ident.add t identifier env.modules in
587 let module_paths = Ident.add t path env.module_paths in
588 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
589 inner rest { env with modules; module_paths; shadowed }
590
591 | `Class (t,t2,t3,t4, is_hidden_item, loc) :: rest ->
592 let name = Ident.name t in
593 let is_shadowed = class_name_exists name rest in
594 let class_types = match t4 with
595 | None -> [t;t2;t3]
596 | Some t4 -> [t;t2;t3;t4]
597 in
598 let identifier, shadowed =
599 if is_shadowed
600 then Mk.class_(parent, TypeName.shadowed_of_string name), class_types @ env.shadowed
601 else Mk.class_(parent, (if is_hidden_item then TypeName.hidden_of_string else TypeName.make_std) name), env.shadowed
602 in
603
604 let classes =
605 List.fold_right (fun id classes -> Ident.add id identifier classes)
606 class_types env.classes in
607
608 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
609
610 inner rest { env with classes; shadowed }
611
612 | `ClassType (t,t2,t3, is_hidden_item, loc) :: rest ->
613 let name = Ident.name t in
614 let is_shadowed = class_type_name_exists name rest in
615 let class_types = match t3 with
616 | None -> [t;t2]
617 | Some t3 -> [t;t2;t3]
618 in
619 let identifier, shadowed =
620 if is_shadowed
621 then Mk.class_type(parent, TypeName.shadowed_of_string name), class_types @ env.shadowed
622 else Mk.class_type(parent, (if is_hidden_item then TypeName.hidden_of_string else TypeName.make_std) name), env.shadowed
623 in
624 let class_types =
625 List.fold_right (fun id class_types -> Ident.add id identifier class_types)
626 class_types env.class_types in
627 (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
628 inner rest { env with class_types; shadowed }
629
630 | [] -> env
631 in inner items env
632
633let identifier_of_loc : t -> Location.t -> Odoc_model.Paths.Identifier.t option = fun env loc ->
634 try Some (LocHashtbl.find env.loc_to_ident loc) with Not_found -> None
635
636let iter_located_identifier : t -> (Location.t -> Odoc_model.Paths.Identifier.t -> unit) -> unit = fun env f ->
637 LocHashtbl.iter f env.loc_to_ident
638
639let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t =
640 fun parent sg env ->
641 let items = extract_signature_tree_items false sg.sig_items |> flatten_includes in
642 add_items parent items env
643
644let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t =
645 fun parent sg env ->
646 let items = extract_structure_tree_items false sg.str_items |> flatten_includes in
647 add_items parent items env
648
649let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t =
650 fun parent sg env ->
651 let items = extract_signature_type_items Exported sg in
652 add_items parent items env
653
654let add_parameter parent id name env =
655 let hidden = ModuleName.is_hidden name in
656 let oid = Odoc_model.Paths.Identifier.Mk.parameter(parent, name) in
657 let path = `Identifier (oid, hidden) in
658 let module_paths = Ident.add id path env.module_paths in
659 let modules = Ident.add id oid env.modules in
660 let parameters = Ident.add id oid env.parameters in
661 { env with module_paths; modules; parameters }
662
663let find_module env id =
664 Ident.find_same id env.module_paths
665
666let find_module_identifier env id =
667 Ident.find_same id env.modules
668
669let find_parameter_identifier env id =
670 Ident.find_same id env.parameters
671
672let find_module_type env id =
673 Ident.find_same id env.module_types
674
675let find_type_identifier env id =
676 Ident.find_same id env.types
677
678let find_constructor_identifier env id =
679 Ident.find_same id env.constructors
680
681let find_exception_identifier env id =
682 Ident.find_same id env.exceptions
683
684let find_extension_identifier env id =
685 Ident.find_same id env.extensions
686
687let find_value_identifier env id =
688 Ident.find_same id env.values
689
690(** Lookup a type in the environment. If it isn't found, it means it's a core
691 type. *)
692let find_type env id =
693 try Some (Ident.find_same id env.types :> Id.Path.Type.t)
694 with Not_found -> (
695 try Some (Ident.find_same id env.classes :> Id.Path.Type.t)
696 with Not_found -> (
697 try Some (Ident.find_same id env.class_types :> Id.Path.Type.t)
698 with Not_found -> None))
699
700let find_class_type env id =
701 try
702 (Ident.find_same id env.classes :> Id.Path.ClassType.t)
703 with Not_found ->
704 (Ident.find_same id env.class_types :> Id.Path.ClassType.t)
705
706let find_class_identifier env id =
707 Ident.find_same id env.classes
708
709let find_class_type_identifier env id =
710 Ident.find_same id env.class_types
711
712let ident_is_global_or_predef id =
713#if defined OXCAML
714 Ident.is_global_or_predef id
715#else
716 Ident.persistent id
717#endif
718
719let is_shadowed
720 env id =
721 List.mem id env.shadowed
722module Path = struct
723
724 let read_module_ident env id =
725 if ident_is_global_or_predef id then `Root (ModuleName.of_ident id)
726 else
727 try find_module env id
728 with Not_found -> assert false
729
730 let read_module_type_ident env id =
731 try
732 `Identifier (find_module_type env id, false)
733 with Not_found -> assert false
734
735 let read_type_ident env id =
736 match find_type env id with
737 | Some id -> `Identifier (id , false)
738 | None -> `Resolved (`CoreType (TypeName.of_ident id))
739
740 let read_value_ident env id : Paths.Path.Value.t =
741 `Identifier (find_value_identifier env id, false)
742
743 let read_class_type_ident env id : Paths.Path.ClassType.t =
744 try
745 `Identifier (find_class_type env id, false)
746 with Not_found ->
747 `DotT (`Root (ModuleName.make_std "*"), (TypeName.of_ident id))
748 (* TODO remove this hack once the fix for PR#6650
749 is in the OCaml release *)
750
751 (* When a type is a classtype path (with a #), the # is stripped off because
752 each ident is mapped to the identifier named for the ident without a
753 hash. e.g. in the following, we take the name of the identifier from
754 cd_id_class, and therefore even [Pident #u/10] will map to identifier
755 [u].
756
757 Typedtree.Tsig_class_type
758 [{Typedtree.ci_virt = Asttypes.Concrete; ci_params = [];
759 ci_id_name = {Asttypes.txt = ...; loc = ...}; ci_id_class = u/13[14];
760 ci_id_class_type = u/12[14]; ci_id_object = u/11[14];
761 ci_id_typehash = #u/10[14];
762
763 For a dotted path though, we have to strip the # off manually here, so
764 [read_class_type] and [read_type] both need the following function.
765 *)
766 let strip_hash s =
767 if s.[0]='#' then String.sub s 1 (String.length s - 1) else s
768
769 let rec read_module : t -> Path.t -> Paths.Path.Module.t = fun env -> function
770 | Path.Pident id -> read_module_ident env id
771#if OCAML_VERSION >= (4,8,0)
772 | Path.Pdot(p, s) -> `Dot(read_module env p, ModuleName.make_std s)
773#else
774 | Path.Pdot(p, s, _) -> `Dot(read_module env p, ModuleName.make_std s)
775#endif
776 | Path.Papply(p, arg) -> `Apply(read_module env p, read_module env arg)
777#if OCAML_VERSION >= (5,1,0)
778 | Path.Pextra_ty _ -> assert false
779#endif
780
781 let read_module_type env = function
782 | Path.Pident id -> read_module_type_ident env id
783#if OCAML_VERSION >= (4,8,0)
784 | Path.Pdot(p, s) -> `DotMT(read_module env p, ModuleTypeName.make_std s)
785#else
786 | Path.Pdot(p, s, _) -> `DotMT(read_module env p, ModuleTypeName.make_std s)
787#endif
788 | Path.Papply(_, _)-> assert false
789#if OCAML_VERSION >= (5,1,0)
790 | Path.Pextra_ty _ -> assert false
791#endif
792
793 let read_class_type env = function
794 | Path.Pident id -> read_class_type_ident env id
795#if OCAML_VERSION >= (4,8,0)
796 | Path.Pdot(p, s) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
797#else
798 | Path.Pdot(p, s, _) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
799#endif
800 | Path.Papply(_, _)-> assert false
801#if OCAML_VERSION >= (5,1,0)
802 | Path.Pextra_ty _ -> assert false
803#endif
804
805#if OCAML_VERSION < (5,1,0)
806 let read_type env = function
807#else
808 let rec read_type env = function
809#endif
810 | Path.Pident id -> read_type_ident env id
811#if OCAML_VERSION >= (4,8,0)
812 | Path.Pdot(p, s) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
813#else
814 | Path.Pdot(p, s, _) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
815#endif
816 | Path.Papply(_, _)-> assert false
817#if OCAML_VERSION >= (5,1,0)
818 | Path.Pextra_ty (p,_) -> read_type env p
819#endif
820
821 let read_value env = function
822 | Path.Pident id -> read_value_ident env id
823#if OCAML_VERSION >= (4,8,0)
824 | Path.Pdot(p, s) -> `DotV(read_module env p, ValueName.make_std s)
825#else
826 | Path.Pdot(p, s, _) -> `DotV(read_module env p, ValueName.make_std s)
827#endif
828 | Path.Papply(_, _) -> assert false
829#if OCAML_VERSION >= (5,1,0)
830 | Path.Pextra_ty _ -> assert false
831#endif
832
833end
834
835module Fragment = struct
836
837 let lmap read_module = function
838 | Longident.Lident s -> `Dot (`Root, s)
839#if OCAML_VERSION >= (5,4,0)
840 | Longident.Ldot (p,s) -> `Dot (read_module p.txt, s.txt)
841#else
842 | Longident.Ldot (p,s) -> `Dot (read_module p, s)
843#endif
844 | _ -> assert false
845
846
847 let rec read_module : Longident.t -> Paths.Fragment.Module.t =
848 fun l -> lmap (fun p -> (read_module p :> Paths.Fragment.Signature.t)) l
849
850 let read_module_type : Longident.t -> Paths.Fragment.ModuleType.t =
851 lmap (fun p -> (read_module p:>Paths.Fragment.Signature.t ))
852
853 let read_type = lmap (fun p -> (read_module p:> Paths.Fragment.Signature.t))
854
855end