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 Typedtree
19
20module OCamlPath = Path
21
22open Odoc_model.Paths
23open Odoc_model.Lang
24open Odoc_model.Names
25
26module Env = Ident_env
27module Paths = Odoc_model.Paths
28
29type env = Cmi.env = {
30 ident_env : Ident_env.t;
31 warnings_tag : string option;
32}
33
34let cmti_builddir : string ref = ref ""
35let read_module_expr : (env -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset")
36
37let opt_map f = function
38 | None -> None
39 | Some x -> Some (f x)
40
41let read_label = Cmi.read_label
42
43let rec read_core_type env container ctyp =
44 let open TypeExpr in
45 match ctyp.ctyp_desc with
46#if defined OXCAML
47 | Ttyp_var (None, _jkind_annot) -> Any
48 | Ttyp_var (Some s, jkind_annot) ->
49 let jkind = match jkind_annot with
50 | Some { Parsetree.pjkind_desc = Pjk_abbreviation name; _ } ->
51 if name = "value" then None else Some name
52 | _ -> None
53 in
54 Var (s, jkind)
55#else
56 | Ttyp_any -> Any
57 | Ttyp_var s -> Var (s, None)
58#endif
59 | Ttyp_arrow(lbl, arg, res) ->
60 let lbl = read_label lbl in
61#if OCAML_VERSION < (4,3,0)
62 (* NOTE(@ostera): Unbox the optional value for this optional labelled
63 argument since the 4.02.x representation includes it explicitly. *)
64 let arg = match lbl with
65 | None | Some(Label(_)) -> read_core_type env container arg
66 | Some(Optional(_)) | Some(RawOptional(_)) ->
67 let arg' = match arg.ctyp_desc with
68 | Ttyp_constr(_, _, param :: _) -> param
69 | _ -> arg
70 in
71 read_core_type env container arg'
72#else
73 let arg = read_core_type env container arg
74#endif
75 in
76 let res = read_core_type env container res in
77#if defined OXCAML
78 let arg_modes, ret_modes = match Types.get_desc ctyp.ctyp_type with
79 | Tarrow((_lbl, marg, mret), _arg, _res, _) ->
80 let arg_modes = Cmi.extract_arg_modes marg in
81 (* Suppress return modes when the return type is itself a function.
82 A closure capturing a local argument is necessarily local, so
83 the return mode is always implied. Showing it is redundant.
84 This matches the elision logic in cmi.cppo.ml and Printtyp. *)
85 let ret_modes = match Types.get_desc _res with
86 | Tarrow _ -> []
87 | _ -> Cmi.extract_arg_modes mret
88 in
89 (arg_modes, ret_modes)
90 | _ -> ([], [])
91 in
92 Arrow(lbl, arg, res, arg_modes, ret_modes)
93#else
94 Arrow(lbl, arg, res, [], [])
95#endif
96 | Ttyp_tuple typs ->
97#if OCAML_VERSION >= (5,4,0) || defined OXCAML
98 let typs = List.map (fun (lbl,x) -> lbl, read_core_type env container x) typs in
99#else
100 let typs = List.map (fun x -> None, read_core_type env container x) typs in
101#endif
102 Tuple typs
103#if defined OXCAML
104 | Ttyp_unboxed_tuple typs ->
105 let typs = List.map (fun (l, t) -> l, read_core_type env container t) typs in
106 Unboxed_tuple typs
107#endif
108 | Ttyp_constr(p, _, params) ->
109 let p = Env.Path.read_type env.ident_env p in
110 let params = List.map (read_core_type env container) params in
111 Constr(p, params)
112 | Ttyp_object(methods, closed) ->
113 let open TypeExpr.Object in
114 let fields =
115 List.map
116#if OCAML_VERSION < (4,6,0)
117 (fun (name, _, typ) ->
118 Method {name; type_ = read_core_type env container typ})
119#elif OCAML_VERSION < (4,8,0)
120 (function
121 | OTtag (name, _, typ) ->
122 Method {
123 name = name.txt;
124 type_ = read_core_type env container typ;
125 }
126 | OTinherit typ -> Inherit (read_core_type env container typ))
127#else
128 (function
129 | {of_desc=OTtag (name, typ); _} ->
130 Method {
131 name = name.txt;
132 type_ = read_core_type env container typ;
133 }
134 | {of_desc=OTinherit typ; _} -> Inherit (read_core_type env container typ))
135#endif
136 methods
137 in
138 Object {fields; open_ = (closed = Asttypes.Open)}
139 | Ttyp_class(p, _, params) ->
140 let p = Env.Path.read_class_type env.ident_env p in
141 let params = List.map (read_core_type env container) params in
142 Class(p, params)
143#if defined OXCAML
144 | Ttyp_alias(typ, var, _layout) -> (
145 (* TODO: presumably we want the layout, eventually *)
146#else
147 | Ttyp_alias(typ, var) -> (
148#endif
149 let typ = read_core_type env container typ in
150#if defined OXCAML
151 match var with
152 | None -> typ
153 | Some var ->
154#endif
155#if OCAML_VERSION >= (5,2,0)
156 Alias(typ, var.txt)
157#else
158 Alias(typ, var)
159#endif
160 )
161 | Ttyp_variant(fields, closed, present) ->
162 let open TypeExpr.Polymorphic_variant in
163 let elements =
164 fields |> List.map begin fun field ->
165#if OCAML_VERSION >= (4,8,0)
166 match field.rf_desc with
167 | Ttag(name, constant, arguments) ->
168 let attributes = field.rf_attributes in
169#else
170 match field with
171 | Ttag(name, attributes, constant, arguments) ->
172#endif
173 let arguments =
174 List.map (read_core_type env container) arguments in
175#if OCAML_VERSION >= (4,6,0)
176 let name = name.txt in
177#endif
178 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container attributes in
179 Constructor {name; constant; arguments; doc}
180 | Tinherit typ -> Type (read_core_type env container typ)
181 end
182 in
183 let kind =
184 if closed = Asttypes.Open then Open
185 else match present with
186 | None -> Fixed
187 | Some names -> Closed names
188 in
189 Polymorphic_variant {kind; elements}
190 | Ttyp_poly([], typ) -> read_core_type env container typ
191#if defined OXCAML
192 | Ttyp_poly(vars, typ) ->
193 let extract_jkind_annot = function
194 | Some { Parsetree.pjkind_desc = Pjk_abbreviation name; _ } ->
195 if name = "value" then None else Some name
196 | _ -> None
197 in
198 Poly(List.map (fun (s, jk) -> (s, extract_jkind_annot jk)) vars, read_core_type env container typ)
199#else
200 | Ttyp_poly(vars, typ) -> Poly(List.map (fun s -> (s, None)) vars, read_core_type env container typ)
201#endif
202#if OCAML_VERSION >= (5,4,0)
203 | Ttyp_package {tpt_path = pack_path; tpt_cstrs=pack_fields; _} ->
204#else
205 | Ttyp_package {pack_path; pack_fields; _} ->
206#endif
207 let open TypeExpr.Package in
208 let path = Env.Path.read_module_type env.ident_env pack_path in
209 let substitutions =
210 List.map
211 (fun (frag, typ) ->
212 let frag = Env.Fragment.read_type frag.Location.txt in
213 let typ = read_core_type env container typ in
214 (frag, typ))
215 pack_fields
216 in
217 Package {path; substitutions}
218#if OCAML_VERSION >= (5,2,0)
219 | Ttyp_open (_p,_l,t) ->
220 (* TODO: adjust model *)
221 read_core_type env container t
222#endif
223#if defined OXCAML
224 | Ttyp_quote typ -> Quote (read_core_type env container typ)
225 | Ttyp_splice typ -> Splice (read_core_type env container typ)
226 | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, [])
227 | Ttyp_of_kind _ -> assert false
228#endif
229
230let read_value_description env parent vd =
231 let open Signature in
232 let id = Env.find_value_identifier env.ident_env vd.val_id in
233 let source_loc = None in
234 let container =
235 (parent : Identifier.Signature.t :> Identifier.LabelParent.t)
236 in
237 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container vd.val_attributes in
238 let type_ = read_core_type env container vd.val_desc in
239 let value =
240 match vd.val_prim with
241 | [] -> Value.Abstract
242 | primitives -> External primitives
243 in
244 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir vd.val_loc) in
245#if defined OXCAML
246 let modalities = Cmi.extract_modalities vd.val_val.val_modalities in
247#else
248 let modalities = [] in
249#endif
250 Value { Value.id; source_loc; doc; type_; value ; source_loc_jane; modalities }
251
252let read_type_parameter (ctyp, var_and_injectivity) =
253 let open TypeDecl in
254 let desc =
255 match ctyp.ctyp_desc with
256#if defined OXCAML
257 | Ttyp_var (None, _layout) -> Any
258 | Ttyp_var (Some s, layout) ->
259 let jkind = match layout with
260 | Some { Parsetree.pjkind_desc = Pjk_abbreviation name; _ } ->
261 if name = "value" then None else Some name
262 | _ -> None
263 in
264 Var (s, jkind)
265#else
266 | Ttyp_any -> Any
267 | Ttyp_var s -> Var (s, None)
268#endif
269 | _ -> assert false
270 in
271 let variance, injectivity =
272#if OCAML_VERSION < (4,12,0)
273 let var =
274 match var_and_injectivity with
275 | Covariant -> Some Pos
276 | Contravariant -> Some Neg
277 | Invariant -> None in
278 var, false
279#else
280 let var =
281 match fst var_and_injectivity with
282 | Covariant -> Some Pos
283 | Contravariant -> Some Neg
284#if OCAML_VERSION >= (5,4,0)
285 | Bivariant -> Some Bivariant
286#endif
287 | NoVariance -> None in
288 let injectivity = match snd var_and_injectivity with
289 | Injective -> true
290 | NoInjectivity -> false in
291 var, injectivity
292#endif
293 in
294 {desc; variance; injectivity}
295
296#if defined OXCAML
297let is_mutable = Types.is_mutable
298#else
299let is_mutable ld = ld = Mutable
300#endif
301
302let read_label_declaration env parent label_parent ld =
303 let open TypeDecl.Field in
304 let open Odoc_model.Names in
305 let name = Ident.name ld.ld_id in
306 let id = Identifier.Mk.field(parent, FieldName.make_std name) in
307 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in
308 let mutable_ = is_mutable ld.ld_mutable in
309 let type_ = read_core_type env label_parent ld.ld_type in
310 {id; doc; mutable_; type_}
311
312let read_unboxed_label_declaration env parent label_parent ld =
313 let open TypeDecl.UnboxedField in
314 let open Odoc_model.Names in
315 let name = Ident.name ld.ld_id in
316 let id = Identifier.Mk.unboxed_field(parent, UnboxedFieldName.make_std name) in
317 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in
318 let mutable_ = is_mutable ld.ld_mutable in
319 let type_ = read_core_type env label_parent ld.ld_type in
320 {id; doc; mutable_; type_}
321
322let read_constructor_declaration_arguments env parent label_parent arg =
323 let open TypeDecl.Constructor in
324#if OCAML_VERSION < (4,3,0)
325 ignore parent;
326 Tuple (List.map (read_core_type env label_parent) arg)
327#else
328 match arg with
329 | Cstr_tuple args ->
330#if defined OXCAML
331 Tuple (List.map (fun arg -> read_core_type env label_parent arg.ca_type) args)
332#else
333 Tuple (List.map (fun arg -> read_core_type env label_parent arg) args)
334#endif
335 | Cstr_record lds ->
336 Record (List.map (read_label_declaration env parent label_parent) lds)
337#endif
338
339let read_constructor_declaration env parent cd =
340 let open TypeDecl.Constructor in
341 let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in
342 let container = (parent :> Identifier.FieldParent.t) in
343 let label_container = (container :> Identifier.LabelParent.t) in
344 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container cd.cd_attributes in
345 let args =
346 read_constructor_declaration_arguments
347 env container label_container cd.cd_args
348 in
349 let res = opt_map (read_core_type env label_container) cd.cd_res in
350 {id; doc; args; res}
351
352let read_type_kind env parent =
353 let open TypeDecl.Representation in function
354 | Ttype_abstract -> None
355 | Ttype_variant cstrs ->
356 let cstrs = List.map (read_constructor_declaration env parent) cstrs in
357 Some (Variant cstrs)
358 | Ttype_record lbls ->
359 let parent = (parent :> Identifier.FieldParent.t) in
360 let label_parent = (parent :> Identifier.LabelParent.t) in
361 let lbls =
362 List.map (read_label_declaration env parent label_parent) lbls in
363 Some (Record lbls)
364#if defined OXCAML
365 | Ttype_record_unboxed_product lbls ->
366 let parent = (parent :> Identifier.UnboxedFieldParent.t) in
367 let label_parent = (parent :> Identifier.LabelParent.t) in
368 let lbls =
369 List.map (read_unboxed_label_declaration env parent label_parent) lbls in
370 Some (Record_unboxed_product lbls)
371#endif
372 | Ttype_open -> Some Extensible
373
374let read_type_equation env container decl =
375 let open TypeDecl.Equation in
376 let params = List.map read_type_parameter decl.typ_params in
377 let private_ = (decl.typ_private = Private) in
378 let manifest = opt_map (read_core_type env container) decl.typ_manifest in
379 let constraints =
380 List.map
381 (fun (typ1, typ2, _) ->
382 (read_core_type env container typ1,
383 read_core_type env container typ2))
384 decl.typ_cstrs
385 in
386 {params; private_; manifest; constraints}
387
388let read_type_declaration env parent decl =
389 let open TypeDecl in
390 let id = Env.find_type_identifier env.ident_env decl.typ_id in
391 let source_loc = None in
392 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
393 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in
394 let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
395 let equation = read_type_equation env container decl in
396 let representation = read_type_kind env id decl.typ_kind in
397 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir decl.typ_loc) in
398 {id; source_loc; doc; canonical; equation; representation; source_loc_jane}
399
400let read_type_declarations env parent rec_flag decls =
401 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
402 let items =
403 let open Signature in
404 List.fold_left
405 (fun (acc, recursive) decl ->
406 if Btype.is_row_name (Ident.name decl.typ_id)
407 then (acc, recursive)
408 else begin
409 let comments =
410 Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag decl.typ_attributes in
411 let comments = List.map (fun com -> Comment com) comments in
412 let decl = read_type_declaration env parent decl in
413 ((Type (recursive, decl)) :: (List.rev_append comments acc), And)
414 end)
415 ([], rec_flag) decls
416 |> fst
417 in
418 List.rev items
419
420#if OCAML_VERSION >= (4,8,0)
421let read_type_substitutions env parent decls =
422 List.map (fun decl -> Odoc_model.Lang.Signature.TypeSubstitution (read_type_declaration env parent decl)) decls
423#endif
424
425let read_extension_constructor env parent ext =
426 let open Extension.Constructor in
427 let id = Env.find_extension_identifier env.ident_env ext.ext_id in
428 let source_loc = None in
429 let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
430 let label_container = (container :> Identifier.LabelParent.t) in
431 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container ext.ext_attributes in
432 match ext.ext_kind with
433 | Text_rebind _ -> assert false
434#if OCAML_VERSION >= (4, 14, 0)
435 | Text_decl(_, args, res) ->
436#else
437 | Text_decl(args, res) ->
438#endif
439 let args =
440 read_constructor_declaration_arguments
441 env container label_container args
442 in
443 let res = opt_map (read_core_type env label_container) res in
444 {id; source_loc; doc; args; res}
445
446let read_type_extension env parent tyext =
447 let open Extension in
448 let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in
449 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
450 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container tyext.tyext_attributes in
451 let type_params = List.map read_type_parameter tyext.tyext_params in
452 let private_ = (tyext.tyext_private = Private) in
453 let constructors =
454 List.map (read_extension_constructor env parent) tyext.tyext_constructors
455 in
456 { parent; type_path; doc; type_params; private_; constructors; }
457
458let read_exception env parent (ext : extension_constructor) =
459 let open Exception in
460 let id = Env.find_exception_identifier env.ident_env ext.ext_id in
461 let source_loc = None in
462 let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
463 let label_container = (container :> Identifier.LabelParent.t) in
464 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container ext.ext_attributes in
465 match ext.ext_kind with
466 | Text_rebind _ -> assert false
467#if OCAML_VERSION >= (4, 14, 0)
468 | Text_decl(_, args, res) ->
469#else
470 | Text_decl(args, res) ->
471#endif
472 let args =
473 read_constructor_declaration_arguments
474 env container label_container args
475 in
476 let res = opt_map (read_core_type env label_container) res in
477 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir ext.ext_loc) in
478 {id; source_loc; doc; args; res; source_loc_jane}
479
480let rec read_class_type_field env parent ctf =
481 let open ClassSignature in
482 let open Odoc_model.Names in
483 let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
484 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ctf.ctf_attributes in
485 match ctf.ctf_desc with
486 | Tctf_val(name, mutable_, virtual_, typ) ->
487 let open InstanceVariable in
488 let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in
489 let mutable_ = (mutable_ = Mutable) in
490 let virtual_ = (virtual_ = Virtual) in
491 let type_ = read_core_type env container typ in
492 Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
493 | Tctf_method(name, private_, virtual_, typ) ->
494 let open Method in
495 let id = Identifier.Mk.method_(parent, MethodName.make_std name) in
496 let private_ = (private_ = Private) in
497 let virtual_ = (virtual_ = Virtual) in
498 let type_ = read_core_type env container typ in
499 Some (Method {id; doc; private_; virtual_; type_})
500 | Tctf_constraint(typ1, typ2) ->
501 let left = read_core_type env container typ1 in
502 let right = read_core_type env container typ2 in
503 Some (Constraint {left; right; doc})
504 | Tctf_inherit cltyp ->
505 let expr = read_class_signature env parent container cltyp in
506 Some (Inherit {expr; doc})
507 | Tctf_attribute attr ->
508 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
509 | None -> None
510 | Some doc -> Some (Comment doc)
511
512and read_self_type env container typ =
513 match typ.ctyp_desc with
514#if defined OXCAML
515 | Ttyp_var (None, _) -> None
516#else
517 | Ttyp_any -> None
518#endif
519 | _ -> Some (read_core_type env container typ)
520
521and read_class_signature env parent label_parent cltyp =
522 let open ClassType in
523 match cltyp.cltyp_desc with
524 | Tcty_constr(p, _, params) ->
525 let p = Env.Path.read_class_type env.ident_env p in
526 let params = List.map (read_core_type env label_parent) params in
527 Constr(p, params)
528 | Tcty_signature csig ->
529 let open ClassSignature in
530 let self = read_self_type env label_parent csig.csig_self in
531 let items =
532 List.fold_left
533 (fun rest item ->
534 match read_class_type_field env parent item with
535 | None -> rest
536 | Some item -> item :: rest)
537 [] csig.csig_fields
538 in
539 let items = List.rev items in
540 let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in
541 let items =
542 match doc_post with
543 | {elements=[]; _} -> items
544 | _ -> Comment (`Docs doc_post) :: items
545 in
546 Signature {self; items; doc}
547 | Tcty_arrow _ -> assert false
548#if OCAML_VERSION >= (4,8,0)
549 | Tcty_open (_, cty) -> read_class_signature env parent label_parent cty
550#elif OCAML_VERSION >= (4,6,0)
551 | Tcty_open (_, _, _, _, cty) -> read_class_signature env parent label_parent cty
552#endif
553
554let read_class_type_declaration env parent cltd =
555 let open ClassType in
556 let id = Env.find_class_type_identifier env.ident_env cltd.ci_id_class_type in
557 let source_loc = None in
558 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
559 let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag cltd.ci_attributes in
560 let virtual_ = (cltd.ci_virt = Virtual) in
561 let params = List.map read_type_parameter cltd.ci_params in
562 let expr = read_class_signature env (id :> Identifier.ClassSignature.t) container cltd.ci_expr in
563 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir cltd.ci_loc) in
564 { id; source_loc; doc; virtual_; params; expr; expansion = None ; source_loc_jane }
565
566let read_class_type_declarations env parent cltds =
567 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
568 let open Signature in
569 List.fold_left begin fun (acc,recursive) cltd ->
570 let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag cltd.ci_attributes in
571 let comments = List.map (fun com -> Comment com) comments in
572 let cltd = read_class_type_declaration env parent cltd in
573 ((ClassType (recursive, cltd))::(List.rev_append comments acc), And)
574 end ([], Ordinary) cltds
575 |> fst
576 |> List.rev
577
578let rec read_class_type env parent label_parent cty =
579 let open Class in
580 match cty.cltyp_desc with
581 | Tcty_constr _ | Tcty_signature _ ->
582 ClassType (read_class_signature env parent label_parent cty)
583 | Tcty_arrow(lbl, arg, res) ->
584 let lbl = read_label lbl in
585 let arg = read_core_type env label_parent arg in
586 let res = read_class_type env parent label_parent res in
587 Arrow(lbl, arg, res)
588#if OCAML_VERSION >= (4,8,0)
589 | Tcty_open (_, cty) -> read_class_type env parent label_parent cty
590#elif OCAML_VERSION >= (4,6,0)
591 | Tcty_open (_, _, _, _, cty) -> read_class_type env parent label_parent cty
592#endif
593
594let read_class_description env parent cld =
595 let open Class in
596 let id = Env.find_class_identifier env.ident_env cld.ci_id_class in
597 let source_loc = None in
598 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
599 let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag cld.ci_attributes in
600 let virtual_ = (cld.ci_virt = Virtual) in
601 let params = List.map read_type_parameter cld.ci_params in
602 let type_ = read_class_type env (id :> Identifier.ClassSignature.t) container cld.ci_expr in
603 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir cld.ci_loc) in
604 { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane}
605
606let read_class_descriptions env parent clds =
607 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
608 let open Signature in
609 List.fold_left begin fun (acc, recursive) cld ->
610 let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag cld.ci_attributes in
611 let comments = List.map (fun com -> Comment com) comments in
612 let cld = read_class_description env parent cld in
613 ((Class (recursive, cld))::(List.rev_append comments acc), And)
614 end ([], Ordinary) clds
615 |> fst
616 |> List.rev
617
618let rec read_with_constraint env global_parent parent (_, frag, constr) =
619 let _ = global_parent in
620 let open ModuleType in
621 match constr with
622 | Twith_type decl ->
623 let frag = Env.Fragment.read_type frag.Location.txt in
624 let eq = read_type_equation env parent decl in
625 TypeEq(frag, eq)
626 | Twith_module(p, _) ->
627 let frag = Env.Fragment.read_module frag.Location.txt in
628 let eq = read_module_equation env p in
629 ModuleEq(frag, eq)
630 | Twith_typesubst decl ->
631 let frag = Env.Fragment.read_type frag.Location.txt in
632 let eq = read_type_equation env parent decl in
633 TypeSubst(frag, eq)
634 | Twith_modsubst(p, _) ->
635 let frag = Env.Fragment.read_module frag.Location.txt in
636 let p = Env.Path.read_module env.ident_env p in
637 ModuleSubst(frag, p)
638#if OCAML_VERSION >= (4,13,0)
639 | Twith_modtype mty ->
640 let frag = Env.Fragment.read_module_type frag.Location.txt in
641 let mty = read_module_type env global_parent parent mty in
642 ModuleTypeEq(frag, mty)
643 | Twith_modtypesubst mty ->
644 let frag = Env.Fragment.read_module_type frag.Location.txt in
645 let mty = read_module_type env global_parent parent mty in
646 ModuleTypeSubst(frag, mty)
647#endif
648
649and read_module_type env parent label_parent mty =
650 let open ModuleType in
651 match mty.mty_desc with
652 | Tmty_ident(p, _) -> Path { p_path = Env.Path.read_module_type env.ident_env p; p_expansion = None }
653 | Tmty_signature sg ->
654 let sg, () = read_signature Odoc_model.Semantics.Expect_none env parent sg in
655 Signature sg
656#if OCAML_VERSION >= (4,10,0)
657 | Tmty_functor(parameter, res) ->
658 let f_parameter, env =
659 match parameter with
660 | Unit -> FunctorParameter.Unit, env
661 | Named (id_opt, _, arg) ->
662 let id, env =
663 match id_opt with
664 | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_"), env
665 | Some id ->
666 let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
667 let env = {env with ident_env = e'} in
668 Env.find_parameter_identifier e' id, env
669 in
670 let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in
671 Named { id; expr = arg; }, env
672 in
673 let res = read_module_type env (Identifier.Mk.result parent) label_parent res in
674 Functor (f_parameter, res)
675#else
676 | Tmty_functor(id, _, arg, res) ->
677 let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
678 let new_env = {env with ident_env = new_env} in
679 let f_parameter =
680 match arg with
681 | None -> Odoc_model.Lang.FunctorParameter.Unit
682 | Some arg ->
683 let id = Ident_env.find_parameter_identifier new_env.ident_env id in
684 let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in
685 Named { FunctorParameter. id; expr = arg }
686 in
687 let res = read_module_type new_env (Identifier.Mk.result parent) label_parent res in
688 Functor( f_parameter, res)
689#endif
690 | Tmty_with(body, subs) -> (
691 let body = read_module_type env parent label_parent body in
692 let subs = List.map (read_with_constraint env parent label_parent) subs in
693 match Odoc_model.Lang.umty_of_mty body with
694 | Some w_expr ->
695 With {w_substitutions=subs; w_expansion=None; w_expr }
696 | None ->
697 failwith "error")
698 | Tmty_typeof mexpr ->
699 let decl =
700 match mexpr.mod_desc with
701 | Tmod_ident(p, _) ->
702 let p = Env.Path.read_module env.ident_env p in
703 TypeOf {t_desc = ModPath p; t_original_path = p; t_expansion = None}
704 | Tmod_structure {str_items = [{str_desc = Tstr_include {incl_mod; _}; _}]; _} -> begin
705 match Typemod.path_of_module incl_mod with
706 | Some p ->
707 let p = Env.Path.read_module env.ident_env p in
708 TypeOf {t_desc=StructInclude p; t_original_path = p; t_expansion = None}
709 | None ->
710 !read_module_expr env parent label_parent mexpr
711 end
712 | _ ->
713 !read_module_expr env parent label_parent mexpr
714 in
715 decl
716 | Tmty_alias _ -> assert false
717#if defined OXCAML
718 | Tmty_strengthen (mty, path, _) ->
719 let mty = read_module_type env parent label_parent mty in
720 let s_path = Env.Path.read_module env.ident_env path in
721 match Odoc_model.Lang.umty_of_mty mty with
722 | Some s_expr ->
723 (* We always strengthen with aliases *)
724 Strengthen {s_expr; s_path; s_aliasable = true; s_expansion = None}
725 | None -> failwith "invalid Tmty_strengthen"
726#endif
727
728(** Like [read_module_type] but handle the canonical tag in the top-comment. If
729 [canonical] is [Some _], no tag is expected in the top-comment. *)
730and read_module_type_maybe_canonical env parent container ~canonical mty =
731 match (canonical, mty.mty_desc) with
732 | None, Tmty_signature sg ->
733 let sg, canonical =
734 read_signature Odoc_model.Semantics.Expect_canonical env parent sg
735 in
736 (ModuleType.Signature sg, canonical)
737 | _, _ -> (read_module_type env parent container mty, canonical)
738
739and read_module_type_declaration env parent mtd =
740 let open ModuleType in
741 let id = Env.find_module_type env.ident_env mtd.mtd_id in
742 let source_loc = None in
743 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
744 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
745 let expr, canonical =
746 match mtd.mtd_type with
747 | Some mty ->
748 let expr, canonical =
749 read_module_type_maybe_canonical env
750 (id :> Identifier.Signature.t)
751 container ~canonical mty
752 in
753 (Some expr, canonical)
754 | None -> (None, canonical)
755 in
756 let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
757 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir mtd.mtd_loc) in
758 { id; source_loc; doc; canonical; expr ; source_loc_jane}
759
760and read_module_declaration env parent md =
761 let open Module in
762#if OCAML_VERSION >= (4,10,0)
763 match md.md_id with
764 | None -> None
765 | Some id ->
766 let mid = Env.find_module_identifier env.ident_env id in
767#else
768 let mid = Env.find_module_identifier env.ident_env md.md_id in
769#endif
770 let id = (mid :> Identifier.Module.t) in
771 let source_loc = None in
772 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
773 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container md.md_attributes in
774 let type_, canonical =
775 match md.md_type.mty_desc with
776 | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical)
777 | _ ->
778 let expr, canonical =
779 read_module_type_maybe_canonical env
780 (id :> Identifier.Signature.t)
781 container ~canonical md.md_type
782 in
783 (ModuleType expr, canonical)
784 in
785 let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
786 let hidden =
787#if OCAML_VERSION >= (4,10,0)
788 match canonical, mid.iv with
789 | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
790 | _,_ -> false
791#else
792 match canonical, mid.iv with
793 | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
794 | _ -> false
795#endif
796 in
797 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmti_builddir md.md_loc) in
798 Some {id; source_loc; doc; type_; canonical; hidden; source_loc_jane}
799
800and read_module_declarations env parent mds =
801 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
802 let open Signature in
803 List.fold_left
804 (fun (acc, recursive) md ->
805 let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag md.md_attributes in
806 let comments = List.map (fun com -> Comment com) comments in
807 match read_module_declaration env parent md with
808 | Some md -> ((Module (recursive, md))::(List.rev_append comments acc), And)
809 | None -> acc, recursive)
810 ([], Rec) mds
811 |> fst
812 |> List.rev
813
814and read_module_equation env p =
815 let open Module in
816 Alias (Env.Path.read_module env.ident_env p, None)
817
818and read_signature_item env parent item =
819 let open Signature in
820 match item.sig_desc with
821 | Tsig_value vd ->
822 [read_value_description env parent vd]
823#if OCAML_VERSION < (4,3,0)
824 | Tsig_type decls ->
825 let rec_flag = Ordinary in
826#else
827 | Tsig_type (rec_flag, decls) ->
828 let rec_flag =
829 match rec_flag with
830 | Recursive -> Ordinary
831 | Nonrecursive -> Nonrec
832 in
833#endif
834 read_type_declarations env parent rec_flag decls
835 | Tsig_typext tyext ->
836 [TypExt (read_type_extension env parent tyext)]
837 | Tsig_exception ext ->
838#if OCAML_VERSION >= (4,8,0)
839 [Exception (read_exception env parent ext.tyexn_constructor)]
840#else
841 [Exception (read_exception env parent ext)]
842#endif
843 | Tsig_module md -> begin
844 match read_module_declaration env parent md with
845 | Some m -> [Module (Ordinary, m)]
846 | None -> []
847 end
848 | Tsig_recmodule mds ->
849 read_module_declarations env parent mds
850 | Tsig_modtype mtd ->
851 [ModuleType (read_module_type_declaration env parent mtd)]
852 | Tsig_open o ->
853 [
854 Open (read_open env parent o)
855 ]
856#if defined OXCAML
857 | Tsig_include (incl, _) ->
858#else
859 | Tsig_include incl ->
860#endif
861 read_include env parent incl
862 | Tsig_class cls ->
863 read_class_descriptions env parent cls
864 | Tsig_class_type cltyps ->
865 read_class_type_declarations env parent cltyps
866 | Tsig_attribute attr -> begin
867 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
868 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
869 | None -> []
870 | Some doc -> [Comment doc]
871 end
872#if OCAML_VERSION >= (4,8,0)
873 | Tsig_typesubst tst ->
874 read_type_substitutions env parent tst
875 | Tsig_modsubst mst ->
876 [ModuleSubstitution (read_module_substitution env parent mst)]
877#if OCAML_VERSION >= (4,13,0)
878 | Tsig_modtypesubst mtst ->
879 [ModuleTypeSubstitution (read_module_type_substitution env parent mtst)]
880#endif
881
882
883and read_module_substitution env parent ms =
884 let open ModuleSubstitution in
885 let id = Env.find_module_identifier env.ident_env ms.ms_id in
886 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
887 let doc, () = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_none container ms.ms_attributes in
888 let manifest = Env.Path.read_module env.ident_env ms.ms_manifest in
889 { id; doc; manifest }
890
891#if OCAML_VERSION >= (4,13,0)
892and read_module_type_substitution env parent mtd =
893 let open ModuleTypeSubstitution in
894 let id = Env.find_module_type env.ident_env mtd.mtd_id in
895 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
896 let doc, () = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in
897 let expr = match opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type with
898 | None -> assert false
899 | Some x -> x
900 in
901 {id; doc; manifest=expr;}
902#endif
903
904
905#endif
906
907and read_include env parent incl =
908 let open Include in
909 let loc = Doc_attr.read_location incl.incl_loc in
910 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
911 let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
912 let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
913 (* Use a synthetic parent for the include's module type expression to avoid
914 identifier conflicts with items in the enclosing signature. Items inside
915 the include expression (like TypeSubstitutions) will get identifiers under
916 this synthetic parent, which won't clash with the real parent's items. *)
917 let include_parent = Identifier.fresh_include_parent parent in
918 let include_container = (include_parent :> Identifier.LabelParent.t) in
919 let expr = read_module_type env include_parent include_container incl.incl_mod in
920 let umty = Odoc_model.Lang.umty_of_mty expr in
921 let expansion = { content; shadowed; } in
922#if defined OXCAML
923 match umty, incl.incl_kind with
924 | Some uexpr, Tincl_structure ->
925#else
926 match umty with
927 | Some uexpr ->
928#endif
929 let decl = Include.ModuleType uexpr in
930 [Include {parent; doc; decl; expansion; expanded = false; status; strengthened=None; loc }]
931 | _ ->
932 (* TODO: Handle [include functor] *)
933 content.items
934
935and read_open env parent o =
936 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
937 let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag o.open_attributes in
938 #if OCAML_VERSION >= (4,8,0)
939 let signature = o.open_bound_items in
940 #else
941 let signature = [] in
942 #endif
943 let expansion, _ = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature signature) in
944 { expansion; doc }
945
946and read_signature :
947 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
948 _ * 'tags =
949 fun internal_tags env parent sg ->
950 let e' = Env.add_signature_tree_items parent sg env.ident_env in
951 let env = { env with ident_env = e' } in
952 let items, (doc, doc_post), tags =
953 let classify item =
954 match item.sig_desc with
955 | Tsig_attribute attr -> Some (`Attribute attr)
956 | Tsig_open _ -> Some `Open
957 | _ -> None
958 in
959 Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent sg.sig_items
960 in
961 let items =
962 List.fold_left
963 (fun items item ->
964 List.rev_append (read_signature_item env parent item) items)
965 [] items
966 |> List.rev
967 in
968 match doc_post with
969 | {elements=[]; _} ->
970 ({ Signature.items; compiled = false; removed = []; doc }, tags)
971 | _ ->
972 ({ Signature.items = Comment (`Docs doc_post) :: items; compiled=false; removed = []; doc }, tags)
973
974let read_interface root name ~warnings_tag intf =
975 let id =
976 Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name)
977 in
978 let sg, canonical =
979 read_signature Odoc_model.Semantics.Expect_canonical
980 { ident_env = Env.empty (); warnings_tag }
981 id intf
982 in
983 let canonical =
984 match canonical with
985 | None -> None
986 | Some s -> Some (Doc_attr.conv_canonical_module s)
987 in
988 (id, sg, canonical)