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 Asttypes
18open Types
19module OCamlPath = Path
20
21open Odoc_model.Paths
22open Odoc_model.Lang
23open Odoc_model.Names
24
25module Env = Ident_env
26module Paths = Odoc_model.Paths
27
28
29type env = {
30 ident_env : Env.t;
31 warnings_tag : string option; (** used to suppress warnings *)
32}
33
34let empty_doc env = { Odoc_model.Comment.elements = []; warnings_tag = env.warnings_tag }
35
36module Compat = struct
37#if OCAML_VERSION >= (4, 14, 0)
38#if OCAML_VERSION >= (5, 3, 0)
39 let newty2 = Btype.newty2
40#endif
41
42 (** this is the type on which physical equality is meaningful *)
43 type repr_type_node = Types.transient_expr
44
45 (** repr has morally type [type_expr -> repr_type_node] in all OCaml
46 versions *)
47 let repr x = Transient_expr.repr x
48
49 let get_desc = Types.get_desc
50 let get_row_name = Types.row_name
51 let row_field_repr = Types.row_field_repr
52 let field_kind_repr = Types.field_kind_repr
53 let static_row_repr = Btype.static_row
54 let row_closed = Types.row_closed
55 let row_fields = Types.row_fields
56 let field_public = Types.Fpublic
57 let self_type = Btype.self_type
58 let csig_self x = x.Types.csig_self
59 let row_repr x = x
60 let concr_mem = Types.Meths.mem
61 let csig_concr x = x.Types.csig_meths
62 let eq_type = Types.eq_type
63#if OCAML_VERSION >= (5,4,0) || defined OXCAML
64 let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None,ty])
65#else
66 let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty])
67#endif
68#else
69 type repr_type_node = Types.type_expr
70 let repr = Btype.repr
71 let get_desc x = (repr x).Types.desc
72 let get_row_name x = x.Types.row_name
73 let row_field_repr = Btype.row_field_repr
74 let field_kind_repr = Btype.field_kind_repr
75 let static_row_repr x = Btype.static_row (Btype.row_repr x)
76 let row_closed x = x.Types.row_closed
77 let row_fields x = x.Types.row_fields
78 let field_public = Types.Fpresent
79 let self_type = Ctype.self_type
80 let csig_self x = Btype.repr x.Types.csig_self
81 let row_repr = Btype.row_repr
82 let concr_mem = Types.Concr.mem
83 let csig_concr x = x.Types.csig_concr
84 let eq_type x y = x == y || repr x == repr y
85
86 (** Create a new node pointing to [ty] that is printed in the same way as
87 [ty]*)
88 let invisible_wrap ty =
89 Btype.(newty2 generic_level (Ttuple [None, ty]))
90#endif
91end
92
93let proxy ty = Compat.(repr (Btype.proxy ty))
94
95let opt_map f = function
96 | None -> None
97 | Some x -> Some (f x)
98
99let opt_iter f = function
100 | None -> ()
101 | Some x -> f x
102
103let read_label lbl =
104 let open TypeExpr in
105#if OCAML_VERSION < (4,3,0)
106 (* NOTE(@ostera): 4.02 does not have an Asttypes variant for whether the
107 * label exists, and is an optional label or not, so I went back to string
108 * manipulation *)
109 if String.length lbl == 0
110 then None
111 else match String.get lbl 0 with
112 | '?' -> Some (Optional (String.sub lbl 1 (String.length lbl - 1)))
113 | _ -> Some (Label lbl)
114#elif defined OXCAML
115 match lbl with
116 | Types.Nolabel -> None
117 | Types.Labelled s -> Some (Label s)
118 | Types.Optional s -> Some (Optional s)
119 | Types.Position s -> (* FIXME: do better? *) Some (Label s)
120#else
121 match lbl with
122 | Asttypes.Nolabel -> None
123 | Asttypes.Labelled s -> Some (Label s)
124 | Asttypes.Optional s -> Some (Optional s)
125#endif
126
127(* Handle type variable names *)
128
129(** To identify equal type node for type variables, we need a map from the
130 representative type node to names. Otherwise, equivalent variables would end
131 up with distinct names *)
132let used_names : (Compat.repr_type_node * string) list ref = ref []
133let name_counter = ref 0
134let reserved_names = ref []
135
136let reset_names () = used_names := []; name_counter := 0; reserved_names := []
137
138let reserve_name = function
139 | Some name ->
140 if not (List.mem name !reserved_names) then
141 reserved_names := name :: !reserved_names
142 | None -> ()
143
144let rec next_name () =
145 let name =
146 if !name_counter < 26
147 then String.make 1 (Char.chr(97 + !name_counter))
148 else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
149 string_of_int(!name_counter / 26)
150 in
151 incr name_counter;
152 if List.mem name !reserved_names then next_name ()
153 else name
154
155let fresh_name base =
156 let current_name = ref base in
157 let i = ref 0 in
158 while List.exists (fun (_, name') -> !current_name = name') !used_names do
159 current_name := base ^ (string_of_int !i);
160 i := !i + 1;
161 done;
162 !current_name
163
164let name_of_type_repr (ty : Compat.repr_type_node) =
165 try
166 List.assq ty !used_names
167 with Not_found ->
168 let base =
169 match ty.desc with
170#if defined OXCAML
171 | Tvar { name = Some name; _ } | Tunivar { name = Some name; _ } -> name
172#else
173 | Tvar (Some name) | Tunivar (Some name) -> name
174#endif
175 | _ -> next_name ()
176 in
177 let name = fresh_name base in
178 if name <> "_" then used_names := (ty, name) :: !used_names;
179 name
180
181let name_of_type ty = name_of_type_repr (Compat.repr ty)
182
183let remove_names tyl =
184 used_names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !used_names
185
186(* Handle recursive types and shared row variables *)
187
188let aliased: Compat.repr_type_node list ref = ref []
189let used_aliases = ref []
190
191let reset_aliased () = aliased := []; used_aliases := []
192
193let is_aliased px = List.memq px !aliased
194
195let aliasable (ty : Types.type_expr) =
196 match Compat.get_desc ty with
197 | Tvar _ | Tunivar _ | Tpoly _ -> false
198 | _ -> true
199
200let add_alias_proxy px =
201 if not (List.memq px !aliased) then begin
202 aliased := px :: !aliased;
203 match px.desc with
204#if defined OXCAML
205 | Tvar { name; _ } | Tunivar { name; _ } ->
206#else
207 | Tvar name | Tunivar name ->
208#endif
209 reserve_name name
210 | _ -> ()
211 end
212
213let add_alias ty = add_alias_proxy (proxy ty)
214
215let used_alias (px : Compat.repr_type_node) = List.memq px !used_aliases
216
217let use_alias (px : Compat.repr_type_node) = used_aliases := px :: !used_aliases
218
219let visited_rows: Compat.repr_type_node list ref = ref []
220
221let reset_visited_rows () = visited_rows := []
222
223let is_row_visited px = List.memq px !visited_rows
224
225let visit_row px =
226 visited_rows := px :: !visited_rows
227
228let visit_object ty px =
229 if Ctype.opened_object ty then
230 visited_rows := px :: !visited_rows
231
232let namable_row row =
233 Compat.get_row_name row <> None &&
234 List.for_all
235 (fun (_, f) ->
236 match Compat.row_field_repr f with
237#if OCAML_VERSION >= (4, 14, 0)
238 | Reither(c, l, _) ->
239#else
240 | Reither(c, l, _, _) ->
241#endif
242 Compat.row_closed row && if c then l = [] else List.length l = 1
243 | _ -> true)
244 (Compat.row_fields row)
245
246let mark_type ty =
247 let rec loop visited ty =
248 let px = proxy ty in
249 if List.memq px visited && aliasable ty then add_alias_proxy px else
250 let visited = px :: visited in
251 match Compat.get_desc ty with
252#if defined OXCAML
253 | Tvar { name; _ } | Tunivar { name; _ } ->
254#else
255 | Tvar name | Tunivar name ->
256#endif
257 reserve_name name
258 | Tarrow(_, ty1, ty2, _) ->
259 loop visited ty1;
260 loop visited ty2
261#if OCAML_VERSION >= (5,4,0) || defined OXCAML
262 | Ttuple tyl -> List.iter (fun (_lbl,x) -> loop visited x) tyl
263#else
264 | Ttuple tyl -> List.iter (loop visited) tyl
265#endif
266#if defined OXCAML
267 | Tunboxed_tuple tyl -> List.iter (fun (_, ty) -> loop visited ty) tyl
268#endif
269 | Tconstr(_, tyl, _) ->
270 List.iter (loop visited) tyl
271 | Tvariant row ->
272 if is_row_visited px then add_alias_proxy px else
273 begin
274 if not (Compat.static_row_repr row) then visit_row px;
275 match Compat.get_row_name row with
276 | Some(_, tyl) when namable_row row ->
277 List.iter (loop visited) tyl
278 | _ ->
279 Btype.iter_row (loop visited) row
280 end
281 | Tobject (fi, nm) ->
282 if is_row_visited px then add_alias_proxy px else
283 begin
284 visit_object ty px;
285 match !nm with
286 | None ->
287 let fields, _ = Ctype.flatten_fields fi in
288 List.iter
289 (fun (_, kind, ty) ->
290 if Compat.field_kind_repr kind = Compat.field_public then
291 loop visited ty)
292 fields
293 | Some (_, l) ->
294 List.iter (loop visited) (List.tl l)
295 end
296 | Tfield(_, kind, ty1, ty2) when Compat.field_kind_repr kind = Compat.field_public ->
297 loop visited ty1;
298 loop visited ty2
299 | Tfield(_, _, _, ty2) ->
300 loop visited ty2
301 | Tnil -> ()
302 | Tpoly (ty, tyl) ->
303 List.iter (fun t -> add_alias t) tyl;
304 loop visited ty
305#if OCAML_VERSION>=(5,4,0)
306 | Tpackage p ->
307 List.iter (fun (_,x) -> loop visited x) p.pack_cstrs
308#elif OCAML_VERSION>=(4,13,0)
309 | Tpackage(_,tyl) ->
310 List.iter (fun (_,x) -> loop visited x) tyl
311#else
312 | Tpackage(_, _, tyl) ->
313 List.iter (loop visited) tyl
314#endif
315#if OCAML_VERSION<(4,13,0)
316 | Tsubst ty -> loop visited ty
317#else
318 | Tsubst (ty,_) -> loop visited ty
319#endif
320#if defined OXCAML
321 | Tquote typ -> loop visited typ
322 | Tsplice typ -> loop visited typ
323 | Tof_kind _ -> ()
324#endif
325 | Tlink _ -> assert false
326 in
327 loop [] ty
328
329let reset_context () =
330 reset_names ();
331 reset_aliased ();
332 reset_visited_rows ()
333
334let mark_type_expr t =
335 reset_context ();
336 mark_type t
337
338let mark_value_description vd =
339 reset_context ();
340 mark_type vd.val_type
341
342let mark_type_parameter param =
343 let px = proxy param in
344 add_alias_proxy px;
345 mark_type param;
346 if aliasable param then use_alias px
347
348#if OCAML_VERSION<(4,13,0)
349let tvar_none ty = ty.desc <- Tvar None
350#elif OCAML_VERSION < (4,14,0)
351let tvar_none ty = Types.Private_type_expr.set_desc ty (Tvar None)
352#elif defined OXCAML
353let tvar_none ty jkind =
354 Types.Transient_expr.(set_desc (coerce ty) (Tvar { name = None; jkind }))
355#else
356let tvar_none ty = Types.Transient_expr.(set_desc (coerce ty) (Tvar None))
357#endif
358
359let wrap_constrained_params tyl =
360 let params =
361 List.fold_left
362 (fun tyl ty ->
363 if List.exists (Compat.eq_type ty) tyl
364 then Compat.invisible_wrap ty :: tyl
365 else ty :: tyl)
366 (* Two parameters might be identical due to a constraint but we need to
367 print them differently in order to make the output syntactically valid.
368 We use [Ttuple [ty]] because it is printed as [ty]. *)
369 [] tyl
370 in List.rev params
371
372let prepare_type_parameters params manifest =
373 let params = wrap_constrained_params params in
374 begin match manifest with
375 | Some ty ->
376 let vars = Ctype.free_variables ty in
377 List.iter
378 (fun ty -> match Compat.get_desc ty with
379#if defined OXCAML
380 | Tvar { name = Some "_"; jkind } ->
381 if List.memq ty vars then tvar_none ty jkind
382#else
383 | Tvar (Some "_") ->
384 if List.memq ty vars then tvar_none ty
385#endif
386 | _ -> ())
387 params
388 | None -> ()
389 end;
390 params
391
392(* NOTE(@ostera): constructor with inlined records were introduced post 4.02 *)
393let mark_constructor_args =
394#if OCAML_VERSION < (4,3,0)
395 List.iter mark_type
396#else
397 function
398#if defined OXCAML
399 | Cstr_tuple args -> List.iter (fun carg -> mark_type carg.ca_type) args
400#else
401 | Cstr_tuple args -> List.iter mark_type args
402#endif
403 | Cstr_record lds -> List.iter (fun ld -> mark_type ld.ld_type) lds
404#endif
405
406let mark_type_kind = function
407#if OCAML_VERSION >= (5,2,0)
408 | Type_abstract _ -> ()
409#else
410 | Type_abstract -> ()
411#endif
412#if defined OXCAML
413 | Type_variant (cds,_,_) ->
414#elif OCAML_VERSION >= (4,13,0)
415 | Type_variant (cds,_) ->
416#else
417 | Type_variant cds ->
418#endif
419 List.iter
420 (fun cd ->
421 mark_constructor_args cd.cd_args;
422 opt_iter mark_type cd.cd_res)
423 cds
424#if defined OXCAML
425 | Type_record_unboxed_product(lds, _, _) ->
426 List.iter (fun ld -> mark_type ld.ld_type) lds
427 | Type_record(lds, _, _) ->
428#else
429 | Type_record(lds, _) ->
430#endif
431 List.iter (fun ld -> mark_type ld.ld_type) lds
432 | Type_open -> ()
433
434let mark_type_declaration decl =
435 let params = prepare_type_parameters decl.type_params decl.type_manifest in
436 reset_context ();
437 List.iter mark_type_parameter params;
438 opt_iter mark_type decl.type_manifest;
439 mark_type_kind decl.type_kind;
440 params
441
442let mark_extension_constructor ext =
443 mark_constructor_args ext.ext_args;
444 opt_iter mark_type ext.ext_ret_type
445
446let mark_type_extension type_params exts =
447 let type_params = prepare_type_parameters type_params None in
448 reset_context ();
449 List.iter mark_type_parameter type_params;
450 List.iter mark_extension_constructor exts;
451 type_params
452
453let mark_type_extension' ext rest =
454 let type_params = ext.ext_type_params in
455 let exts = ext :: (List.map snd rest) in
456 mark_type_extension type_params exts
457
458let mark_exception ext =
459 reset_context ();
460 mark_extension_constructor ext
461
462let rec mark_class_type params = function
463 | Cty_constr (_, tyl, cty) ->
464 let sty = Compat.self_type cty in
465 if is_row_visited (proxy sty)
466 || List.exists aliasable params
467 || List.exists (Ctype.deep_occur sty) tyl
468 then mark_class_type params cty
469 else List.iter mark_type tyl
470 | Cty_signature sign ->
471 let sty = Compat.csig_self sign in
472 let px = proxy sty in
473 if is_row_visited px then add_alias_proxy px
474 else visit_row px;
475 let (fields, _) =
476 Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
477 in
478 List.iter (fun (_, _, ty) -> mark_type ty) fields;
479 Vars.iter (fun _ (_, _, ty) -> mark_type ty) sign.csig_vars;
480 if is_aliased px && aliasable sty then use_alias px
481 | Cty_arrow (_, ty, cty) ->
482 mark_type ty;
483 mark_class_type params cty
484
485let mark_class_type_declaration cltd =
486 reset_context ();
487 List.iter mark_type_parameter cltd.clty_params;
488 mark_class_type cltd.clty_params cltd.clty_type
489
490let mark_class_declaration cld =
491 reset_context ();
492 List.iter mark_type_parameter cld.cty_params;
493 mark_class_type cld.cty_params cld.cty_type
494
495#if defined OXCAML
496(** Extract non-default mode strings from an OxCaml argument mode.
497 Replicates the logic from [Printtyp.tree_of_modes]. *)
498let extract_arg_modes marg =
499 let modes = Mode.Alloc.zap_to_legacy marg in
500 let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in
501 (* Apply implied-default elision rules from Printtyp *)
502 let forkable =
503 match modes.areality, modes.forkable with
504 | Local, Unforkable | Global, Forkable -> None
505 | _, _ -> diff.forkable
506 in
507 let yielding =
508 match modes.areality, modes.yielding with
509 | Local, Yielding | Global, Unyielding -> None
510 | _, _ -> diff.yielding
511 in
512 let contention =
513 match modes.visibility, modes.contention with
514 | Immutable, Contended | Read, Shared | Read_write, Uncontended -> None
515 | _, _ -> diff.contention
516 in
517 let portability =
518 match modes.statefulness, modes.portability with
519 | Stateless, Portable | Observing, Shareable | Stateful, Nonportable -> None
520 | _, _ -> diff.portability
521 in
522 let print_opt print a =
523 Option.map (fun v -> Format.asprintf "%a" print v) a
524 in
525 List.filter_map Fun.id
526 [ print_opt Mode.Locality.Const.print diff.areality
527 ; print_opt Mode.Uniqueness.Const.print diff.uniqueness
528 ; print_opt Mode.Linearity.Const.print diff.linearity
529 ; print_opt Mode.Portability.Const.print portability
530 ; print_opt Mode.Contention.Const.print contention
531 ; print_opt Mode.Forkable.Const.print forkable
532 ; print_opt Mode.Yielding.Const.print yielding
533 ; print_opt Mode.Statefulness.Const.print diff.statefulness
534 ; print_opt Mode.Visibility.Const.print diff.visibility ]
535
536(** Extract jkind/layout string from an OxCaml type variable's jkind.
537 Returns [None] for the default [value] layout or unknown layouts. *)
538let extract_jkind_of_tvar jkind =
539 let desc = Jkind.get jkind in
540 match desc.layout with
541 | Sort (Base Value) -> None (* default — don't annotate *)
542 | Sort (Base b) -> Some (Jkind_types.Sort.to_string_base b)
543 | Sort (Var _) -> None (* sort variable — not determined *)
544 | Product _ -> None (* product layout — complex, skip for now *)
545 | Any -> None
546
547(** Extract non-default modality strings from a value's modalities.
548 Replicates the implied-modality filtering from [Typemode.least_modalities]. *)
549let extract_modalities modalities =
550 let m = Mode.Modality.zap_to_floor modalities in
551 if Mode.Modality.Const.is_id m then []
552 else begin
553 let atoms = Mode.Modality.Const.diff Mode.Modality.Const.id m in
554 (* Compute implied atoms from each annotated atom *)
555 let implied_of_atom (Mode.Modality.Atom (ax, v)) =
556 match ax, v with
557 | Comonadic Areality, Meet_with Global ->
558 [ Mode.Modality.Atom (Comonadic Forkable, Meet_with Mode.Forkable.Const.Forkable)
559 ; Mode.Modality.Atom (Comonadic Yielding, Meet_with Mode.Yielding.Const.Unyielding)
560 ; Mode.Modality.Atom (Monadic Uniqueness, Join_with Mode.Uniqueness.Const.Aliased)
561 ]
562 | Comonadic Areality, Meet_with Local ->
563 [ Mode.Modality.Atom (Comonadic Forkable, Meet_with Mode.Forkable.Const.Unforkable)
564 ; Mode.Modality.Atom (Comonadic Yielding, Meet_with Mode.Yielding.Const.Yielding)
565 ]
566 | Monadic Visibility, Join_with Immutable ->
567 [ Mode.Modality.Atom (Monadic Contention, Join_with Mode.Contention.Const.Contended) ]
568 | Monadic Visibility, Join_with Read ->
569 [ Mode.Modality.Atom (Monadic Contention, Join_with Mode.Contention.Const.Shared) ]
570 | Monadic Visibility, Join_with Read_write ->
571 [ Mode.Modality.Atom (Monadic Contention, Join_with Mode.Contention.Const.Uncontended) ]
572 | Comonadic Statefulness, Meet_with Stateless ->
573 [ Mode.Modality.Atom (Comonadic Portability, Meet_with Mode.Portability.Const.Portable) ]
574 | Comonadic Statefulness, Meet_with Observing ->
575 [ Mode.Modality.Atom (Comonadic Portability, Meet_with Mode.Portability.Const.Shareable) ]
576 | Comonadic Statefulness, Meet_with Stateful ->
577 [ Mode.Modality.Atom (Comonadic Portability, Meet_with Mode.Portability.Const.Nonportable) ]
578 | _ -> []
579 in
580 let implied = List.concat_map implied_of_atom atoms in
581 (* Filter out atoms that are exactly implied by other atoms *)
582 let filtered = List.filter (fun a -> not (List.mem a implied)) atoms in
583 (* Add back atoms on implied axes with overridden (non-implied) values *)
584 let overridden = List.filter_map (fun imp_atom ->
585 let (Mode.Modality.Atom (ax, _v_implied)) = imp_atom in
586 let v_actual = Mode.Modality.Const.proj ax m in
587 let actual_atom = Mode.Modality.Atom (ax, v_actual) in
588 if actual_atom <> imp_atom then Some actual_atom
589 else None
590 ) implied in
591 let final_atoms = filtered @ overridden in
592 List.filter_map (fun (Mode.Modality.Atom (ax, v)) ->
593 let s = Format.asprintf "%a" (Printtyp.modality ax) v in
594 if s = "" then None else Some s
595 ) final_atoms
596 end
597#endif
598
599let rec read_type_expr env typ =
600 let open TypeExpr in
601 let px = proxy typ in
602 if used_alias px then Var (name_of_type typ, None)
603 else begin
604 let alias =
605 if not (is_aliased px && aliasable typ) then None
606 else begin
607 use_alias px;
608 Some (name_of_type typ)
609 end
610 in
611 let typ =
612 match Compat.get_desc typ with
613#if defined OXCAML
614 | Tvar { name; _ } ->
615 (* Tvar is a use site — don't annotate with jkind here.
616 Jkinds are extracted at the Tunivar binding site in Tpoly,
617 matching Printtyp's convention of stating the jkind once
618 at the universal quantifier. *)
619 let nm = match name with Some n -> n | None -> name_of_type typ in
620 if nm = "_" then Any
621 else Var (nm, None)
622 | Tarrow((lbl, marg, mret), arg, res, _) ->
623 let arg_modes = extract_arg_modes marg in
624 (* Suppress return modes when the return type is itself a function.
625 A closure capturing a local argument is necessarily local, so
626 the return mode is always implied. Showing it is redundant.
627 This matches the elision logic in Printtyp.tree_of_modes. *)
628 let ret_modes = match Compat.get_desc res with
629 | Tarrow _ -> []
630 | _ -> extract_arg_modes mret
631 in
632#else
633 | Tvar _ ->
634 let name = name_of_type typ in
635 if name = "_" then Any
636 else Var (name, None)
637 | Tarrow(lbl, arg, res, _) ->
638 let arg_modes = [] in
639 let ret_modes = [] in
640#endif
641 let lbl = read_label lbl in
642 let lbl,arg =
643 match lbl with
644 | Some (Optional s) -> (
645 let read_as_wrapped () =
646 (Some (RawOptional s), read_type_expr env arg)
647 in
648 match Compat.get_desc arg with
649 | Tpoly(arg, []) -> begin
650 match Compat.get_desc arg with
651 | Tconstr(_option, [arg], _) ->
652 lbl, read_type_expr env arg (* Unwrap option if possible *)
653 | _ -> read_as_wrapped ()
654 end
655 | _ ->
656 read_as_wrapped ()) (* If not, mark is as wrapped *)
657 | _ ->
658 lbl, read_type_expr env arg
659 in
660 let res = read_type_expr env res in
661 Arrow(lbl, arg, res, arg_modes, ret_modes)
662 | Ttuple typs ->
663#if OCAML_VERSION >= (5,4,0) || defined OXCAML
664 let typs = List.map (fun (lbl,x) -> lbl, read_type_expr env x) typs in
665#else
666 let typs = List.map (fun x -> None, read_type_expr env x) typs in
667#endif
668 Tuple typs
669#if defined OXCAML
670 | Tunboxed_tuple typs ->
671 let typs = List.map (fun (l,t) -> l, read_type_expr env t) typs in
672 Unboxed_tuple typs
673#endif
674 | Tconstr(p, params, _) ->
675 let p = Env.Path.read_type env.ident_env p in
676 let params = List.map (read_type_expr env) params in
677 Constr(p, params)
678 | Tvariant row -> read_row env px row
679 | Tobject (fi, nm) -> read_object env fi !nm
680 | Tnil | Tfield _ -> read_object env typ None
681 | Tpoly (typ, []) -> read_type_expr env typ
682 | Tpoly (typ, tyl) ->
683 let reprs = List.map Compat.repr tyl in
684 let vars = List.map2 (fun orig repr ->
685 let name = name_of_type_repr repr in
686 (* Extract jkind from the Tunivar binding site.
687 This is the only place jkinds are recorded — use sites
688 (Tvar) intentionally return None to avoid redundancy. *)
689 let jkind =
690#if defined OXCAML
691 match Compat.get_desc orig with
692 | Tunivar { jkind; _ } -> extract_jkind_of_tvar jkind
693 | _ -> None
694#else
695 None
696#endif
697 in
698 (name, jkind)) tyl reprs
699 in
700 let typ = read_type_expr env typ in
701 remove_names reprs;
702 Poly(vars, typ)
703#if defined OXCAML
704 | Tunivar { jkind; _ } -> Var (name_of_type typ, extract_jkind_of_tvar jkind)
705#else
706 | Tunivar _ -> Var (name_of_type typ, None)
707#endif
708#if OCAML_VERSION>=(5,4,0)
709 | Tpackage {pack_path=p; pack_cstrs } ->
710 let eqs = List.filter_map (fun (l,ty) -> Option.map (fun x -> x, ty) (Longident.unflatten l)) pack_cstrs in
711#elif OCAML_VERSION>=(4,13,0)
712 | Tpackage(p,eqs) ->
713#else
714 | Tpackage(p, frags, tyl) ->
715 let eqs = List.combine frags tyl in
716#endif
717 let open TypeExpr.Package in
718 let path = Env.Path.read_module_type env.ident_env p in
719 let substitutions =
720 List.map
721 (fun (frag,typ) ->
722 let frag = Env.Fragment.read_type frag in
723 let typ = read_type_expr env typ in
724 (frag, typ))
725 eqs
726 in
727
728 Package {path; substitutions}
729#if OCAML_VERSION<(4,13,0)
730 | Tsubst typ -> read_type_expr env typ
731#else
732 | Tsubst (typ,_) -> read_type_expr env typ
733#endif
734#if defined OXCAML
735 | Tquote typ -> Quote (read_type_expr env typ)
736 | Tsplice typ -> Splice (read_type_expr env typ)
737 | Tof_kind _ -> assert false
738#endif
739 | Tlink _ -> assert false
740 in
741 match alias with
742 | None -> typ
743 | Some name -> Alias(typ, name)
744 end
745
746and read_row env _px row =
747 let open TypeExpr in
748 let open TypeExpr.Polymorphic_variant in
749 let row = Compat.row_repr row in
750 let fields =
751 if Compat.row_closed row then
752 List.filter (fun (_, f) -> Compat.row_field_repr f <> Rabsent)
753 (Compat.row_fields row)
754 else Compat.row_fields row in
755 let sorted_fields = List.sort (fun (p,_) (q,_) -> compare p q) fields in
756 let present =
757 List.filter
758 (fun (_, f) ->
759 match Compat.row_field_repr f with
760 | Rpresent _ -> true
761 | _ -> false)
762 sorted_fields in
763 let all_present = List.length present = List.length sorted_fields in
764 match Compat.get_row_name row with
765 | Some(p, params) when namable_row row ->
766 let p = Env.Path.read_type env.ident_env p in
767 let params = List.map (read_type_expr env) params in
768 if Compat.row_closed row && all_present then
769 Constr (p, params)
770 else
771 let kind =
772 if all_present then Open else Closed (List.map fst present)
773 in
774 Polymorphic_variant {kind; elements = [Type (Constr (p, params))]}
775 | _ ->
776 let elements =
777 List.map
778 (fun (name, f) ->
779 let doc = empty_doc env in
780 match Compat.row_field_repr f with
781 | Rpresent None ->
782 Constructor {name; constant = true; arguments = []; doc}
783 | Rpresent (Some typ) ->
784 Constructor {
785 name;
786 constant = false;
787 arguments = [read_type_expr env typ];
788 doc;
789 }
790#if OCAML_VERSION >= (4, 14, 0)
791 | Reither(constant, typs, _) ->
792#else
793 | Reither(constant, typs, _, _) ->
794#endif
795 let arguments =
796 List.map (read_type_expr env) typs
797 in
798 Constructor {name; constant; arguments; doc}
799 | Rabsent -> assert false)
800 sorted_fields
801 in
802 let kind =
803 if all_present then
804 if Compat.row_closed row then Fixed
805 else Open
806 else Closed (List.map fst present)
807 in
808 Polymorphic_variant {kind; elements}
809
810and read_object env fi nm =
811 let open TypeExpr in
812 let open TypeExpr.Object in
813 let px = proxy fi in
814 if used_alias px then Var (name_of_type fi, None)
815 else begin
816 use_alias px;
817 match nm with
818 | None ->
819 let (fields, rest) = Ctype.flatten_fields fi in
820 let present_fields =
821 List.fold_right
822 (fun (n, k, t) l ->
823 match Compat.field_kind_repr k with
824 | f when f = Compat.field_public -> (n, t) :: l
825 | _ -> l)
826 fields []
827 in
828 let sorted_fields =
829 List.sort (fun (n, _) (n', _) -> compare n n') present_fields
830 in
831 let methods =
832 List.map
833 (fun (name, typ) -> Method {name; type_ = read_type_expr env typ})
834 sorted_fields
835 in
836 let open_ =
837 match Compat.get_desc rest with
838 | Tvar _ | Tunivar _ -> true
839 | Tconstr _ -> true
840 | Tnil -> false
841 | _ -> assert false
842 in
843 Object {fields = methods; open_}
844 | Some (p, _ :: params) ->
845 let p = Env.Path.read_class_type env.ident_env p in
846 let params = List.map (read_type_expr env) params in
847 Class (p, params)
848 | _ -> assert false
849 end
850
851let read_value_description ({ident_env ; warnings_tag} as env) parent id vd =
852 let open Signature in
853 let id = Env.find_value_identifier ident_env id in
854 let source_loc = None in
855 let container =
856 (parent : Identifier.Signature.t :> Identifier.LabelParent.t)
857 in
858 let doc = Doc_attr.attached_no_tag ~warnings_tag container vd.val_attributes in
859 mark_value_description vd;
860 let type_ = read_type_expr env vd.val_type in
861 let value =
862 match vd.val_kind with
863#if defined OXCAML
864 | Val_reg _ -> Value.Abstract
865#else
866 | Val_reg -> Value.Abstract
867#endif
868 | Val_prim desc ->
869 let primitives =
870 let open Primitive in
871 desc.prim_name
872 :: (match desc.prim_native_name with "" -> [] | name -> [ name ])
873 in
874 External primitives
875 | _ -> assert false
876 in
877 (* Source location is not trustworthy since it's a cmi so left as None *)
878 let source_loc_jane = None in
879#if defined OXCAML
880 let modalities = extract_modalities vd.val_modalities in
881#else
882 let modalities = [] in
883#endif
884 Value { Value.id; source_loc; doc; type_; value ; source_loc_jane; modalities }
885
886#if defined OXCAML
887let is_mutable = Types.is_mutable
888#else
889let is_mutable ld = ld = Mutable
890#endif
891
892let read_label_declaration env parent ld =
893 let open TypeDecl.Field in
894 let name = Ident.name ld.ld_id in
895 let id = Identifier.Mk.field (parent, Odoc_model.Names.FieldName.make_std name) in
896 let doc =
897 Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag
898 (parent :> Identifier.LabelParent.t) ld.ld_attributes
899 in
900 let mutable_ = is_mutable ld.ld_mutable in
901 let type_ = read_type_expr env ld.ld_type in
902 {id; doc; mutable_; type_}
903
904let read_constructor_declaration_arguments env parent arg =
905#if OCAML_VERSION < (4,3,0)
906 (* NOTE(@ostera): constructor with inlined records were introduced post 4.02
907 so it's safe to use Tuple here *)
908 ignore parent;
909 TypeDecl.Constructor.Tuple(List.map (read_type_expr env) arg)
910#else
911 let open TypeDecl.Constructor in
912 match arg with
913#if defined OXCAML
914 | Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg.ca_type) args)
915#else
916 | Cstr_tuple args -> Tuple (List.map (read_type_expr env) args)
917#endif
918 | Cstr_record lds ->
919 Record (List.map (read_label_declaration env parent) lds)
920#endif
921
922let read_constructor_declaration env parent cd =
923 let open TypeDecl.Constructor in
924 let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in
925 let container = (parent :> Identifier.LabelParent.t) in
926 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cd.cd_attributes in
927 let args =
928 read_constructor_declaration_arguments env
929 (parent :> Identifier.FieldParent.t) cd.cd_args
930 in
931 let res = opt_map (read_type_expr env) cd.cd_res in
932 {id; doc; args; res}
933
934let read_type_kind env parent =
935 let open TypeDecl.Representation in function
936#if OCAML_VERSION >= (5,2,0)
937 | Type_abstract _ ->
938#else
939 | Type_abstract ->
940#endif
941 None
942#if defined OXCAML
943 | Type_variant (cstrs,_,_) ->
944#elif OCAML_VERSION >= (4,13,0)
945 | Type_variant (cstrs,_) ->
946#else
947 | Type_variant cstrs ->
948#endif
949 let cstrs =
950 List.map (read_constructor_declaration env parent) cstrs
951 in
952 Some (Variant cstrs)
953#if defined OXCAML
954 | Type_record_unboxed_product(lbls, _, _) ->
955 let lbls =
956 List.map
957 (read_label_declaration env (parent :> Identifier.FieldParent.t))
958 lbls
959 in
960 Some (Record lbls)
961 | Type_record(lbls, _, _) ->
962#else
963 | Type_record(lbls, _) ->
964#endif
965 let lbls =
966 List.map
967 (read_label_declaration env (parent :> Identifier.FieldParent.t))
968 lbls
969 in
970 Some (Record lbls)
971 | Type_open -> Some Extensible
972
973let read_injectivity var =
974#if OCAML_VERSION < (5, 1, 0)
975 let _, _, _, inj = Variance.get_lower var in
976#else
977 let _, _, inj = Variance.get_lower var in
978#endif
979 inj
980
981let read_type_parameter abstr var param =
982 let open TypeDecl in
983 let name = name_of_type param in
984 let desc =
985 if name = "_" then Any
986 else
987#if defined OXCAML
988 let jkind_opt = match Compat.get_desc param with
989 | Tvar { jkind; _ } -> extract_jkind_of_tvar jkind
990 | _ -> None
991 in
992 Var (name, jkind_opt)
993#else
994 Var (name, None)
995#endif
996 in
997 let variance =
998 if not (abstr || aliasable param) then None
999 else begin
1000 let co, cn = Variance.get_upper var in
1001 if not cn then Some Pos
1002 else if not co then Some Neg
1003 else None
1004 end in
1005 let injectivity = read_injectivity var in
1006 {desc; variance; injectivity}
1007
1008let read_type_constraints env params =
1009 List.fold_right
1010 (fun typ1 acc ->
1011 let typ2 = Ctype.unalias typ1 in
1012 if Btype.proxy typ1 != Btype.proxy typ2 then
1013 let typ1 = read_type_expr env typ1 in
1014 let typ2 = read_type_expr env typ2 in
1015 (typ1, typ2) :: acc
1016 else acc)
1017 params []
1018
1019let read_class_constraints env params =
1020 let open ClassSignature in
1021 read_type_constraints env params
1022 |> List.map (fun (left, right) ->
1023 Constraint { Constraint.left; right; doc = empty_doc env })
1024
1025let read_type_declaration env parent id decl =
1026 let open TypeDecl in
1027 let id = Env.find_type_identifier env.ident_env id in
1028 let source_loc = None in
1029 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1030 let doc, canonical =
1031 Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container decl.type_attributes
1032 in
1033 let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
1034 let params = mark_type_declaration decl in
1035 let manifest = opt_map (read_type_expr env) decl.type_manifest in
1036 let constraints = read_type_constraints env params in
1037 let representation = read_type_kind env (id :> Identifier.DataType.t) decl.type_kind in
1038 let abstr =
1039 match decl.type_kind with
1040#if OCAML_VERSION >= (5,2,0)
1041 | Type_abstract _ ->
1042#else
1043 | Type_abstract ->
1044#endif
1045 decl.type_manifest = None || decl.type_private = Private
1046 | Type_record _ ->
1047 decl.type_private = Private
1048#if defined OXCAML
1049 | Type_record_unboxed_product _ ->
1050 decl.type_private = Private
1051#endif
1052#if defined OXCAML
1053 | Type_variant (tll,_,_) ->
1054#elif OCAML_VERSION >= (4,13,0)
1055 | Type_variant (tll,_) ->
1056#else
1057 | Type_variant tll ->
1058#endif
1059 decl.type_private = Private ||
1060 List.exists (fun cd -> cd.cd_res <> None) tll
1061 | Type_open ->
1062 decl.type_manifest = None
1063 in
1064 let params =
1065 List.map2 (read_type_parameter abstr) decl.type_variance params
1066 in
1067 let private_ = (decl.type_private = Private) in
1068 let equation = Equation.{params; manifest; constraints; private_} in
1069 (* Source location is not trustworthy since it's a cmi so left as None *)
1070 let source_loc_jane = None in
1071 {id; source_loc; doc; canonical; equation; representation; source_loc_jane }
1072
1073let read_extension_constructor env parent id ext =
1074 let open Extension.Constructor in
1075 let id = Env.find_extension_identifier env.ident_env id in
1076 let source_loc = None in
1077 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1078 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ext.ext_attributes in
1079 let args =
1080 read_constructor_declaration_arguments env
1081 (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
1082 in
1083 let res = opt_map (read_type_expr env) ext.ext_ret_type in
1084 {id; source_loc; doc; args; res}
1085
1086let read_type_extension env parent id ext rest =
1087 let open Extension in
1088 let type_path = Env.Path.read_type env.ident_env ext.ext_type_path in
1089 let doc = Doc_attr.empty env.warnings_tag in
1090 let type_params = mark_type_extension' ext rest in
1091 let first = read_extension_constructor env parent id ext in
1092 let rest =
1093 List.map
1094 (fun (id, ext) -> read_extension_constructor env parent id ext)
1095 rest
1096 in
1097 let constructors = first :: rest in
1098 let type_params =
1099 List.map (read_type_parameter false Variance.null) type_params
1100 in
1101 let private_ = (ext.ext_private = Private) in
1102 { parent; type_path; type_params;
1103 doc; private_;
1104 constructors; }
1105
1106let read_exception env parent id ext =
1107 let open Exception in
1108 let id = Env.find_exception_identifier env.ident_env id in
1109 let source_loc = None in
1110 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1111 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ext.ext_attributes in
1112 mark_exception ext;
1113 let args =
1114 read_constructor_declaration_arguments env
1115 (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
1116 in
1117 let res = opt_map (read_type_expr env) ext.ext_ret_type in
1118 (* Source location is not trustworthy since it's a cmi so left as None *)
1119 let source_loc_jane = None in
1120 {id; source_loc; doc; args; res; source_loc_jane}
1121
1122let read_method env parent concrete (name, kind, typ) =
1123 let open Method in
1124 let id = Identifier.Mk.method_(parent, Odoc_model.Names.MethodName.make_std name) in
1125 let doc = Doc_attr.empty env.warnings_tag in
1126 let private_ = (Compat.field_kind_repr kind) <> Compat.field_public in
1127 let virtual_ = not (Compat.concr_mem name concrete) in
1128 let type_ = read_type_expr env typ in
1129 ClassSignature.Method {id; doc; private_; virtual_; type_}
1130
1131let read_instance_variable env parent (name, mutable_, virtual_, typ) =
1132 let open InstanceVariable in
1133 let id = Identifier.Mk.instance_variable(parent, Odoc_model.Names.InstanceVariableName.make_std name) in
1134 let doc = Doc_attr.empty env.warnings_tag in
1135 let mutable_ = (mutable_ = Asttypes.Mutable) in
1136 let virtual_ = (virtual_ = Virtual) in
1137 let type_ = read_type_expr env typ in
1138 ClassSignature.InstanceVariable {id; doc; mutable_; virtual_; type_}
1139
1140let read_self_type sty =
1141 let px = proxy sty in
1142 if not (is_aliased px) then None
1143 else Some (TypeExpr.Var (name_of_type_repr px, None))
1144
1145let rec read_class_signature env parent params =
1146 let open ClassType in function
1147 | Cty_constr(p, _, cty) ->
1148 if is_row_visited (proxy (Compat.self_type cty))
1149 || List.exists aliasable params
1150 then read_class_signature env parent params cty
1151 else begin
1152 let p = Env.Path.read_class_type env.ident_env p in
1153 let params = List.map (read_type_expr env) params in
1154 Constr(p, params)
1155 end
1156 | Cty_signature csig ->
1157 let open ClassSignature in
1158 let self = read_self_type csig.csig_self in
1159 let constraints = read_class_constraints env params in
1160 let instance_variables =
1161 Vars.fold
1162 (fun name (mutable_, virtual_, typ) acc ->
1163 (name, mutable_, virtual_, typ) :: acc)
1164 csig.csig_vars []
1165 in
1166 let methods, _ =
1167 Ctype.flatten_fields (Ctype.object_fields csig.csig_self)
1168 in
1169 let methods =
1170 List.filter (fun (name, _, _) -> name <> Btype.dummy_method) methods
1171 in
1172 let instance_variables =
1173 List.map (read_instance_variable env parent) instance_variables
1174 in
1175 let methods =
1176 List.map (read_method env parent (Compat.csig_concr csig)) methods
1177 in
1178 let items = constraints @ instance_variables @ methods in
1179 Signature {self; items; doc = empty_doc env}
1180 | Cty_arrow _ -> assert false
1181
1182let rec read_virtual = function
1183 | Cty_constr(_, _, cty) | Cty_arrow(_, _, cty) -> read_virtual cty
1184 | Cty_signature csig ->
1185 let methods, _ =
1186 Ctype.flatten_fields (Ctype.object_fields csig.csig_self)
1187 in
1188 let virtual_method =
1189 List.exists
1190 (fun (name, _, _) ->
1191 not (name = Btype.dummy_method
1192 || Compat.concr_mem name (Compat.csig_concr csig)))
1193 methods
1194 in
1195 let virtual_instance_variable =
1196 Vars.exists
1197 (fun _ (_, virtual_, _) -> virtual_ = Virtual)
1198 csig.csig_vars
1199 in
1200 virtual_method || virtual_instance_variable
1201
1202let read_class_type_declaration env parent id cltd =
1203 let open ClassType in
1204 let id = Env.find_class_type_identifier env.ident_env id in
1205 let source_loc = None in
1206 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1207 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cltd.clty_attributes in
1208 mark_class_type_declaration cltd;
1209 let params =
1210 List.map2
1211 (read_type_parameter false)
1212 cltd.clty_variance cltd.clty_params
1213 in
1214 let expr =
1215 read_class_signature env (id :> Identifier.ClassSignature.t) cltd.clty_params cltd.clty_type
1216 in
1217 let virtual_ = read_virtual cltd.clty_type in
1218 (* Source location is not trustworthy since it's a cmi so left as None *)
1219 let source_loc_jane = None in
1220 { id; source_loc; doc; virtual_; params; expr; expansion = None ; source_loc_jane}
1221
1222let rec read_class_type env parent params =
1223 let open Class in function
1224 | Cty_constr _ | Cty_signature _ as cty ->
1225 ClassType (read_class_signature env parent params cty)
1226 | Cty_arrow(lbl, arg, cty) ->
1227 let lbl = read_label lbl in
1228 let lbl, arg =
1229 match lbl with
1230 | Some (Optional s) -> (
1231 match Compat.get_desc arg with
1232 | Tconstr(_option, [arg], _) ->
1233 lbl, read_type_expr env arg (* Unwrap option if possible *)
1234 | _ ->
1235 (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *)
1236 | _ ->
1237 lbl, read_type_expr env arg
1238 in
1239 let cty = read_class_type env parent params cty in
1240 Arrow(lbl, arg, cty)
1241
1242let read_class_declaration env parent id cld =
1243 let open Class in
1244 let id = Env.find_class_identifier env.ident_env id in
1245 let source_loc = None in
1246 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1247 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cld.cty_attributes in
1248 mark_class_declaration cld;
1249 let params =
1250 List.map2
1251 (read_type_parameter false)
1252 cld.cty_variance cld.cty_params
1253 in
1254 let type_ =
1255 read_class_type env (id :> Identifier.ClassSignature.t) cld.cty_params cld.cty_type
1256 in
1257 let virtual_ = cld.cty_new = None in
1258 (* Source location is not trustworthy since it's a cmi so left as None *)
1259 let source_loc_jane = None in
1260 { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane}
1261
1262let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) =
1263 let open ModuleType in
1264 match mty with
1265 | Mty_ident p -> Path {p_path = Env.Path.read_module_type env.ident_env p; p_expansion=None }
1266 | Mty_signature sg -> Signature (read_signature env parent sg)
1267 | Mty_functor(parameter, res) ->
1268 let f_parameter, env =
1269 match parameter with
1270 | Unit -> Odoc_model.Lang.FunctorParameter.Unit, env
1271 | Named (id_opt, arg) ->
1272 let id, env = match id_opt with
1273 | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_"), env
1274 | Some id -> let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
1275 Ident_env.find_parameter_identifier e' id, {env with ident_env = e'}
1276 in
1277 let arg = read_module_type env (id :> Identifier.Signature.t) arg in
1278 Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }), env
1279 in
1280 let res = read_module_type env (Identifier.Mk.result parent) res in
1281 Functor( f_parameter, res)
1282 | Mty_alias p ->
1283 let t_original_path = Env.Path.read_module env.ident_env p in
1284 let t_desc = ModPath t_original_path in
1285 TypeOf { t_desc; t_expansion = None; t_original_path }
1286 | Mty_strengthen (mty, p, a) ->
1287 let mty = read_module_type env parent mty in
1288 let s_path = Env.Path.read_module env.ident_env p in
1289 let s_aliasable = match a with
1290 | Aliasable -> true
1291 | Not_aliasable -> false
1292 in
1293 match Odoc_model.Lang.umty_of_mty mty with
1294 | Some s_expr ->
1295 Strengthen {s_expr; s_path; s_aliasable; s_expansion = None}
1296 | None -> failwith "invalid Mty_strengthen"
1297
1298and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) =
1299 let open ModuleType in
1300 let id = Env.find_module_type env.ident_env id in
1301 let source_loc = None in
1302 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1303 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
1304 let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
1305 let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in
1306 (* Source location is not trustworthy since it's a cmi so left as None *)
1307 let source_loc_jane = None in
1308 {id; source_loc; doc; canonical; expr ; source_loc_jane}
1309
1310and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) =
1311 let open Module in
1312 let id = (Env.find_module_identifier env.ident_env ident :> Identifier.Module.t) in
1313 let source_loc = None in
1314 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
1315 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container md.md_attributes in
1316 let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
1317 let type_ =
1318 match md.md_type with
1319 | Mty_alias p -> Alias (Env.Path.read_module env.ident_env p, None)
1320 | _ -> ModuleType (read_module_type env (id :> Identifier.Signature.t) md.md_type)
1321 in
1322 let hidden =
1323 match canonical with
1324 | Some _ -> false
1325 | None -> Odoc_model.Names.contains_double_underscore (Ident.name ident)
1326 in
1327 (* Source location is not trustworthy since it's a cmi so left as None *)
1328 let source_loc_jane = None in
1329 {id; source_loc; doc; type_; canonical; hidden ; source_loc_jane}
1330
1331and read_type_rec_status rec_status =
1332 let open Signature in
1333 match rec_status with
1334 | Trec_first -> Ordinary
1335 | Trec_next -> And
1336 | Trec_not -> Nonrec
1337
1338and read_module_rec_status rec_status =
1339 let open Signature in
1340 match rec_status with
1341 | Trec_not -> Ordinary
1342 | Trec_first -> Rec
1343 | Trec_next -> And
1344
1345and read_signature_noenv env parent (items : Odoc_model.Compat.signature) =
1346 let rec loop (acc,shadowed) items =
1347 let open Signature in
1348 let open Odoc_model.Compat in
1349 let open Include in
1350 match items with
1351 | Sig_value(id, v, _) :: rest ->
1352 let vd = read_value_description env parent id v in
1353 let shadowed =
1354 if Env.is_shadowed env.ident_env id
1355 then
1356 let identifier = Env.find_value_identifier env.ident_env id in
1357 match identifier.iv with
1358 | `Value (_, n) -> { shadowed with s_values = (Odoc_model.Names.parenthesise (Ident.name id), n) :: shadowed.s_values }
1359 else shadowed
1360 in
1361 loop (vd :: acc, shadowed) rest
1362 | Sig_type(id, _, _, _) :: rest
1363 when Btype.is_row_name (Ident.name id) ->
1364 loop (acc, shadowed) rest
1365 | Sig_type(id, decl, rec_status, _)::rest ->
1366 let decl = read_type_declaration env parent id decl in
1367 let shadowed =
1368 if Env.is_shadowed env.ident_env id
1369 then
1370 let identifier = Env.find_type_identifier env.ident_env id in
1371 let `Type (_, name) = identifier.iv in
1372 { shadowed with s_types = (Ident.name id, name) :: shadowed.s_types }
1373 else shadowed
1374 in
1375 loop (Type (read_type_rec_status rec_status, decl)::acc, shadowed) rest
1376 | Sig_typext (id, ext, Text_first, _) :: rest ->
1377 let rec inner_loop inner_acc = function
1378 | Sig_typext(id, ext, Text_next, _) :: rest ->
1379 inner_loop ((id, ext) :: inner_acc) rest
1380 | rest ->
1381 let ext =
1382 read_type_extension env parent id ext (List.rev inner_acc)
1383 in
1384 loop (TypExt ext :: acc, shadowed) rest
1385 in
1386 inner_loop [] rest
1387 | Sig_typext (id, ext, Text_next, _) :: rest ->
1388 let ext = read_type_extension env parent id ext [] in
1389 loop (TypExt ext :: acc, shadowed) rest
1390 | Sig_typext (id, ext, Text_exception, _) :: rest ->
1391 let exn = read_exception env parent id ext in
1392 loop (Exception exn :: acc, shadowed) rest
1393 | Sig_module (id, _, md, rec_status, _)::rest ->
1394 let md = read_module_declaration env parent id md in
1395 let shadowed =
1396 if Env.is_shadowed env.ident_env id
1397 then
1398 let identifier = Env.find_module_identifier env.ident_env id in
1399 let name =
1400 match identifier.iv with
1401 | `Module (_, n) -> n
1402 | `Parameter (_, n) -> n
1403 | `Root (_, n) -> n
1404 in
1405{ shadowed with s_modules = (Ident.name id, name) :: shadowed.s_modules }
1406 else shadowed
1407 in
1408 loop (Module (read_module_rec_status rec_status, md)::acc, shadowed) rest
1409 | Sig_modtype(id, mtd, _) :: rest ->
1410 let mtd = read_module_type_declaration env parent id mtd in
1411 let shadowed =
1412 if Env.is_shadowed env.ident_env id
1413 then
1414 let identifier = Env.find_module_type env.ident_env id in
1415 let name =
1416 match identifier.iv with
1417 | `ModuleType (_, n) -> n
1418 in
1419
1420 { shadowed with s_module_types = (Ident.name id, name) :: shadowed.s_module_types }
1421 else shadowed
1422 in
1423 loop (ModuleType mtd :: acc, shadowed) rest
1424#if OCAML_VERSION < (5,1,0)
1425 | Sig_class(id, cl, rec_status, _) :: Sig_class_type _
1426 :: Sig_type _ :: Sig_type _ :: rest ->
1427#else
1428 | Sig_class(id, cl, rec_status, _) :: Sig_class_type _
1429 :: Sig_type _ :: rest ->
1430#endif
1431 let cl = read_class_declaration env parent id cl in
1432 let shadowed =
1433 if Env.is_shadowed env.ident_env id
1434 then
1435 let identifier = Env.find_class_identifier env.ident_env id in
1436 let name =
1437 match identifier.iv with
1438 | `Class (_, n) -> n
1439 in
1440
1441 { shadowed with s_classes = (Ident.name id, name) :: shadowed.s_classes }
1442 else shadowed
1443 in
1444 loop (Class (read_type_rec_status rec_status, cl)::acc, shadowed) rest
1445#if OCAML_VERSION < (5,1,0)
1446 | Sig_class_type(id, cltyp, rec_status, _)::Sig_type _::Sig_type _::rest ->
1447#else
1448 | Sig_class_type(id, cltyp, rec_status, _)::Sig_type _::rest ->
1449#endif
1450 let cltyp = read_class_type_declaration env parent id cltyp in
1451 let shadowed =
1452 if Env.is_shadowed env.ident_env id
1453 then
1454 let identifier = Env.find_class_type_identifier env.ident_env id in
1455 let name =
1456 match identifier.iv with
1457 | `ClassType (_, n) -> n
1458 in
1459{ shadowed with s_class_types = (Ident.name id, name) :: shadowed.s_class_types }
1460 else shadowed
1461 in
1462 loop (ClassType (read_type_rec_status rec_status, cltyp)::acc, shadowed) rest
1463 (* Skip all of the hidden sig items *)
1464
1465
1466 (* Bad - we expect Sig_class and Sig_class_type to be matched above
1467 with subsequent Sig_type items *)
1468 | Sig_class_type _ :: _
1469 | Sig_class _ :: _ -> assert false
1470
1471 | [] -> ({items = List.rev acc; compiled=false; removed = []; doc = empty_doc env }, shadowed)
1472 in
1473 loop ([],{s_modules=[]; s_module_types=[]; s_values=[];s_types=[]; s_classes=[]; s_class_types=[]}) items
1474
1475and read_signature env parent (items : Odoc_model.Compat.signature) =
1476 let e' = Env.handle_signature_type_items parent items env.ident_env in
1477 let env = { env with ident_env = e' } in
1478 fst @@ read_signature_noenv env parent items
1479
1480
1481let read_interface root name ~warnings_tag intf =
1482 let id =
1483 Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name)
1484 in
1485 let items =
1486 read_signature
1487 { ident_env = Env.empty (); warnings_tag }
1488 id intf
1489 in
1490 (id, items)