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
17
18open Asttypes
19open Typedtree
20
21module OCamlPath = Path
22
23open Odoc_model.Paths
24open Odoc_model.Lang
25
26module Env = Ident_env
27
28type env = Cmi.env = {
29 ident_env : Ident_env.t;
30 warnings_tag : string option;
31}
32
33
34let cmt_builddir : string ref = ref ""
35
36let read_core_type env ctyp =
37 Cmi.read_type_expr env ctyp.ctyp_type
38
39let rec read_pattern env parent doc pat =
40 let source_loc = None in
41 let open Signature in
42 match pat.pat_desc with
43 | Tpat_any -> []
44#if OCAML_VERSION < (5,2,0)
45 | Tpat_var(id, _) ->
46#elif defined OXCAML
47 | Tpat_var(id, _, _uid, _, _) ->
48#else
49 | Tpat_var(id, _, _uid) ->
50#endif
51 let open Value in
52 let id = Env.find_value_identifier env.ident_env id in
53 Cmi.mark_type_expr pat.pat_type;
54 let type_ = Cmi.read_type_expr env pat.pat_type in
55 let value = Abstract in
56 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir pat.pat_loc) in
57 [Value {id; source_loc; doc; type_; value ; source_loc_jane; modalities = [] }]
58#if OCAML_VERSION < (5,2, 0)
59 | Tpat_alias(pat, id, _) ->
60#elif defined OXCAML
61 | Tpat_alias(pat, id, _, _, _, _, _) ->
62#elif OCAML_VERSION < (5,4,0)
63 | Tpat_alias(pat, id, _,_) ->
64#else
65 | Tpat_alias(pat, id,_,_,_) ->
66#endif
67 let open Value in
68 let id = Env.find_value_identifier env.ident_env id in
69 Cmi.mark_type_expr pat.pat_type;
70 let type_ = Cmi.read_type_expr env pat.pat_type in
71 let value = Abstract in
72 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir pat.pat_loc) in
73 Value {id; source_loc; doc; type_; value ; source_loc_jane; modalities = [] } :: read_pattern env parent doc pat
74 | Tpat_constant _ -> []
75 | Tpat_tuple pats ->
76#if OCAML_VERSION >= (5, 4, 0) || defined OXCAML
77 let pats = List.map snd pats (* remove labels *) in
78#endif
79 List.concat (List.map (read_pattern env parent doc) pats)
80#if defined OXCAML
81 | Tpat_unboxed_tuple pats ->
82 List.concat (List.map (fun (_, p, _) -> read_pattern env parent doc p) pats)
83#endif
84#if OCAML_VERSION < (4, 13, 0)
85 | Tpat_construct(_, _, pats) ->
86#else
87 | Tpat_construct(_,_,pats,_) ->
88#endif
89 List.concat (List.map (read_pattern env parent doc) pats)
90 | Tpat_variant(_, None, _) -> []
91 | Tpat_variant(_, Some pat, _) ->
92 read_pattern env parent doc pat
93 | Tpat_record(pats, _) ->
94 List.concat
95 (List.map
96 (fun (_, _, pat) -> read_pattern env parent doc pat)
97 pats)
98#if defined OXCAML
99 | Tpat_record_unboxed_product(pats, _) ->
100 List.concat
101 (List.map
102 (fun (_, _, pat) -> read_pattern env parent doc pat)
103 pats)
104 | Tpat_array (_, _, pats) ->
105#elif OCAML_VERSION < (5, 4, 0)
106 | Tpat_array pats ->
107#else
108 | Tpat_array (_, pats) ->
109#endif
110 List.concat (List.map (read_pattern env parent doc) pats)
111 | Tpat_or(pat, _, _) ->
112 read_pattern env parent doc pat
113 | Tpat_lazy pat ->
114 read_pattern env parent doc pat
115#if OCAML_VERSION >= (4,8,0) && OCAML_VERSION < (4,11,0)
116 | Tpat_exception pat ->
117 read_pattern env parent doc pat
118#endif
119
120let read_value_binding env parent vb =
121 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
122 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container vb.vb_attributes in
123 read_pattern env parent doc vb.vb_pat
124
125let read_value_bindings env parent vbs =
126 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
127 let items =
128 List.fold_left
129 (fun acc vb ->
130 let open Signature in
131 let comments =
132 Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag vb.vb_attributes in
133 let comments = List.map (fun com -> Comment com) comments in
134 let vb = read_value_binding env parent vb in
135 List.rev_append vb (List.rev_append comments acc))
136 [] vbs
137 in
138 List.rev items
139
140let read_type_extension env parent tyext =
141 let open Extension in
142 let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in
143 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
144 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container tyext.tyext_attributes in
145 let type_params =
146 List.map (fun (ctyp, _) -> ctyp.ctyp_type) tyext.tyext_params
147 in
148 let constructors =
149 List.map (fun ext -> ext.ext_type) tyext.tyext_constructors
150 in
151 let type_params =
152 Cmi.mark_type_extension type_params constructors
153 in
154 let type_params =
155 List.map
156 (Cmi.read_type_parameter false Types.Variance.null)
157 type_params
158 in
159 let private_ = (tyext.tyext_private = Private) in
160 let constructors =
161 List.map
162 (fun ext ->
163 Cmi.read_extension_constructor
164 env parent ext.ext_id ext.ext_type)
165 tyext.tyext_constructors
166 in
167 { parent; type_path; doc; type_params; private_; constructors; }
168
169(** Make a standalone comment out of a comment attached to an item that isn't
170 rendered. For example, [constraint] items are read separately and not
171 associated with their comment. *)
172let mk_class_comment = function
173 | { Odoc_model.Comment.elements = []; _} -> None
174 | doc -> Some (ClassSignature.Comment (`Docs doc))
175
176let rec read_class_type_field env parent ctf =
177 let open ClassSignature in
178 let open Odoc_model.Names in
179 let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
180 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ctf.ctf_attributes in
181 match ctf.ctf_desc with
182 | Tctf_val(name, mutable_, virtual_, typ) ->
183 let open InstanceVariable in
184 let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in
185 let mutable_ = (mutable_ = Mutable) in
186 let virtual_ = (virtual_ = Virtual) in
187 let type_ = read_core_type env typ in
188 Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
189 | Tctf_method(name, private_, virtual_, typ) ->
190 let open Method in
191 let id = Identifier.Mk.method_(parent, MethodName.make_std name) in
192 let private_ = (private_ = Private) in
193 let virtual_ = (virtual_ = Virtual) in
194 let type_ = read_core_type env typ in
195 Some (Method {id; doc; private_; virtual_; type_})
196 | Tctf_constraint(_, _) -> mk_class_comment doc
197 | Tctf_inherit cltyp ->
198 let expr = read_class_signature env parent [] cltyp in
199 Some (Inherit {Inherit.expr; doc})
200 | Tctf_attribute attr ->
201 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
202 | None -> None
203 | Some doc -> Some (Comment doc)
204
205and read_class_signature env parent params cltyp =
206 let open ClassType in
207 match cltyp.cltyp_desc with
208 | Tcty_constr(p, _, params) ->
209 let p = Env.Path.read_class_type env.ident_env p in
210 let params = List.map (read_core_type env) params in
211 Constr(p, params)
212 | Tcty_signature csig ->
213 let open ClassSignature in
214 let self =
215 Cmi.read_self_type csig.csig_self.ctyp_type
216 in
217 let constraints = Cmi.read_class_constraints env params in
218 let items =
219 List.fold_left
220 (fun rest item ->
221 match read_class_type_field env parent item with
222 | None -> rest
223 | Some item -> item :: rest)
224 [] csig.csig_fields
225 in
226 let items = constraints @ List.rev items in
227 let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in
228 let items =
229 match doc_post with
230 | { elements = []; _ } -> items
231 | _ -> Comment (`Docs doc_post) :: items
232 in
233 Signature {self; items; doc}
234
235 | Tcty_arrow _ -> assert false
236#if OCAML_VERSION >= (4,6,0)
237 | Tcty_open _ -> assert false
238#endif
239
240let rec read_class_type env parent params cty =
241 let open Class in
242 match cty.cltyp_desc with
243 | Tcty_constr _ | Tcty_signature _ ->
244 ClassType (read_class_signature env parent params cty)
245 | Tcty_arrow(lbl, arg, res) ->
246 let lbl = Cmi.read_label lbl in
247 let arg = read_core_type env arg in
248 let res = read_class_type env parent params res in
249 Arrow(lbl, arg, res)
250#if OCAML_VERSION >= (4,8,0)
251 | Tcty_open (_, cty) -> read_class_type env parent params cty
252#elif OCAML_VERSION >= (4,6,0)
253 | Tcty_open (_, _, _, _, cty) -> read_class_type env parent params cty
254#endif
255
256
257let rec read_class_field env parent cf =
258 let open ClassSignature in
259 let open Odoc_model.Names in
260 let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
261 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container (cf.cf_attributes) in
262 match cf.cf_desc with
263 | Tcf_val({txt = name; _}, mutable_, _, kind, _) ->
264 let open InstanceVariable in
265 let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in
266 let mutable_ = (mutable_ = Mutable) in
267 let virtual_, type_ =
268 match kind with
269 | Tcfk_virtual typ ->
270 true, read_core_type env typ
271 | Tcfk_concrete(_, expr) ->
272 false, Cmi.read_type_expr env expr.exp_type
273 in
274 Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
275 | Tcf_method({txt = name; _}, private_, kind) ->
276 let open Method in
277 let id = Identifier.Mk.method_(parent, MethodName.make_std name) in
278 let private_ = (private_ = Private) in
279 let virtual_, type_ =
280 match kind with
281 | Tcfk_virtual typ ->
282 true, read_core_type env typ
283 | Tcfk_concrete(_, expr) ->
284 (* Types of concrete methods in class implementation begin
285 with the object as first (implicit) argument, so we
286 must keep only the type after the first arrow. *)
287 let type_ =
288 match Cmi.read_type_expr env expr.exp_type with
289 | Arrow (_, _, t, _, _) -> t
290 | t -> t
291 in
292 false, type_
293 in
294 Some (Method {id; doc; private_; virtual_; type_})
295 | Tcf_constraint(_, _) -> mk_class_comment doc
296 | Tcf_inherit(_, cl, _, _, _) ->
297 let expr = read_class_structure env parent [] cl in
298 Some (Inherit {Inherit.expr; doc})
299 | Tcf_initializer _ -> mk_class_comment doc
300 | Tcf_attribute attr ->
301 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
302 | None -> None
303 | Some doc -> Some (Comment doc)
304
305and read_class_structure env parent params cl =
306 let open ClassType in
307 match cl.cl_desc with
308 | Tcl_ident _ | Tcl_apply _ ->
309 Cmi.read_class_signature env parent params cl.cl_type
310 | Tcl_structure cstr ->
311 let open ClassSignature in
312 let self = Cmi.read_self_type cstr.cstr_self.pat_type in
313 let constraints = Cmi.read_class_constraints env params in
314 let items =
315 List.fold_left
316 (fun rest item ->
317 match read_class_field env parent item with
318 | None -> rest
319 | Some item -> item :: rest)
320 [] cstr.cstr_fields
321 in
322 let items = constraints @ List.rev items in
323 let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in
324 let items =
325 match doc_post with
326 | { elements = []; _ } -> items
327 | _ -> Comment (`Docs doc_post) :: items
328 in
329 Signature {self; items; doc}
330 | Tcl_fun _ -> assert false
331 | Tcl_let(_, _, _, cl) -> read_class_structure env parent params cl
332 | Tcl_constraint(cl, None, _, _, _) -> read_class_structure env parent params cl
333 | Tcl_constraint(_, Some cltyp, _, _, _) ->
334 read_class_signature env parent params cltyp
335#if OCAML_VERSION >= (4,8,0)
336 | Tcl_open (_, cl) -> read_class_structure env parent params cl
337#elif OCAML_VERSION >= (4,6,0)
338 | Tcl_open (_, _, _, _, cl) -> read_class_structure env parent params cl
339#endif
340
341
342let rec read_class_expr env parent params cl =
343 let open Class in
344 match cl.cl_desc with
345 | Tcl_ident _ | Tcl_apply _ ->
346 Cmi.read_class_type env parent params cl.cl_type
347 | Tcl_structure _ ->
348 ClassType (read_class_structure env parent params cl)
349 | Tcl_fun(lbl, arg, _, res, _) ->
350 let lbl = Cmi.read_label lbl in
351 let arg = Cmi.read_type_expr env arg.pat_type in
352 let res = read_class_expr env parent params res in
353 Arrow(lbl, arg, res)
354 | Tcl_let(_, _, _, cl) ->
355 read_class_expr env parent params cl
356 | Tcl_constraint(cl, None, _, _, _) ->
357 read_class_expr env parent params cl
358 | Tcl_constraint(_, Some cltyp, _, _, _) ->
359 read_class_type env parent params cltyp
360#if OCAML_VERSION >= (4,8,0)
361 | Tcl_open (_, cl) -> read_class_expr env parent params cl
362#elif OCAML_VERSION >= (4,6,0)
363 | Tcl_open (_, _, _, _, cl) -> read_class_expr env parent params cl
364#endif
365
366let read_class_declaration env parent cld =
367 let open Class in
368 let id = Env.find_class_identifier env.ident_env cld.ci_id_class in
369 let source_loc = None in
370 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
371 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cld.ci_attributes in
372 Cmi.mark_class_declaration cld.ci_decl;
373 let virtual_ = (cld.ci_virt = Virtual) in
374 let clparams =
375 List.map (fun (ctyp, _) -> ctyp.ctyp_type) cld.ci_params
376 in
377 let params =
378 List.map
379 (Cmi.read_type_parameter false Types.Variance.null)
380 clparams
381 in
382 let type_ = read_class_expr env (id :> Identifier.ClassSignature.t) clparams cld.ci_expr in
383 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir cld.ci_loc) in
384 { id; source_loc; doc; virtual_; params; type_; expansion = None ; source_loc_jane}
385
386let read_class_declarations env parent clds =
387 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
388 let open Signature in
389 List.fold_left begin fun (acc, recursive) cld ->
390 let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag cld.ci_attributes in
391 let comments = List.map (fun com -> Comment com) comments in
392 let cld = read_class_declaration env parent cld in
393 ((Class (recursive, cld))::(List.rev_append comments acc), And)
394 end ([], Ordinary) clds
395 |> fst
396 |> List.rev
397
398let rec read_module_expr env parent label_parent mexpr =
399 let open ModuleType in
400 let open Odoc_model.Names in
401 match mexpr.mod_desc with
402 | Tmod_ident _ ->
403 Cmi.read_module_type env parent (Odoc_model.Compat.module_type mexpr.mod_type)
404 | Tmod_structure str ->
405 let sg, () = read_structure Odoc_model.Semantics.Expect_none env parent str in
406 Signature sg
407#if OCAML_VERSION >= (4,10,0)
408 | Tmod_functor(parameter, res) ->
409 let f_parameter, env =
410 match parameter with
411 | Unit -> FunctorParameter.Unit, env
412 | Named (id_opt, _, arg) ->
413 let id, env =
414 match id_opt with
415 | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_"), env
416 | Some id -> let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
417 Env.find_parameter_identifier e' id, {env with ident_env=e'}
418 in
419 let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in
420
421 Named { id; expr=arg }, env
422 in
423 let res = read_module_expr env (Identifier.Mk.result parent) label_parent res in
424 Functor (f_parameter, res)
425#else
426 | Tmod_functor(id, _, arg, res) ->
427 let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
428 let new_env = {env with ident_env = new_env} in
429 let f_parameter =
430 match arg with
431 | None -> FunctorParameter.Unit
432 | Some arg ->
433 let id = Env.find_parameter_identifier new_env.ident_env id in
434 let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in
435 Named { FunctorParameter. id; expr = arg; }
436 in
437 let res = read_module_expr new_env (Identifier.Mk.result parent) label_parent res in
438 Functor(f_parameter, res)
439#endif
440 | Tmod_apply _ ->
441 Cmi.read_module_type env parent (Odoc_model.Compat.module_type mexpr.mod_type)
442#if OCAML_VERSION >= (5,1,0)
443 | Tmod_apply_unit _ ->
444 Cmi.read_module_type env parent (Odoc_model.Compat.module_type mexpr.mod_type)
445#endif
446 | Tmod_constraint(_, _, Tmodtype_explicit mty, _) ->
447 Cmti.read_module_type env parent label_parent mty
448 | Tmod_constraint(mexpr, _, Tmodtype_implicit, _) ->
449 read_module_expr env parent label_parent mexpr
450 | Tmod_unpack(_, mty) ->
451 Cmi.read_module_type env parent (Odoc_model.Compat.module_type mty)
452and unwrap_module_expr_desc = function
453 | Tmod_constraint(mexpr, _, Tmodtype_implicit, _) ->
454 unwrap_module_expr_desc mexpr.mod_desc
455 | desc -> desc
456
457(** Like [read_module_expr] but handle the canonical tag in the top-comment. *)
458and read_module_expr_maybe_canonical env parent container ~canonical mexpr =
459 let open ModuleType in
460 match (canonical, mexpr.mod_desc) with
461 | None, Tmod_structure str ->
462 let sg, canonical =
463 read_structure Odoc_model.Semantics.Expect_canonical env parent str
464 in
465 (Signature sg, canonical)
466 | _ -> (read_module_expr env parent container mexpr, canonical)
467
468and read_module_binding env parent mb =
469 let open Module in
470#if OCAML_VERSION >= (4,10,0)
471 match mb.mb_id with
472 | None -> None
473 | Some id ->
474 let mid = Env.find_module_identifier env.ident_env id in
475#else
476 let mid = Env.find_module_identifier env.ident_env mb.mb_id in
477#endif
478 let id = (mid :> Identifier.Module.t) in
479 let source_loc = None in
480 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
481 let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in
482 let type_, canonical =
483 match unwrap_module_expr_desc mb.mb_expr.mod_desc with
484 | Tmod_ident (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical)
485 | _ ->
486 let id = (id :> Identifier.Signature.t) in
487 let expr, canonical =
488 read_module_expr_maybe_canonical env id container ~canonical mb.mb_expr
489 in
490 (ModuleType expr, canonical)
491 in
492 let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
493 let hidden =
494#if OCAML_VERSION >= (4,10,0)
495 match canonical, mid.iv with
496 | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
497 | Some _, _ -> false
498#else
499 match canonical, mid.iv with
500 | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
501 | Some _, _ -> false
502#endif
503 in
504 let source_loc_jane = Some (Odoc_model.Lang.Source_loc_jane.of_location !cmt_builddir mb.mb_loc) in
505 Some {id; source_loc; doc; type_; canonical; hidden; source_loc_jane}
506
507and read_module_bindings env parent mbs =
508 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t)
509 in
510 let open Signature in
511 List.fold_left
512 (fun (acc, recursive) mb ->
513 let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag mb.mb_attributes in
514 let comments = List.map (fun com -> Comment com) comments in
515 match read_module_binding env parent mb with
516 | Some mb ->
517 ((Module (recursive, mb))::(List.rev_append comments acc), And)
518 | None -> (acc, recursive))
519 ([], Rec) mbs
520 |> fst
521 |> List.rev
522
523and read_structure_item env parent item =
524 let open Signature in
525 match item.str_desc with
526 | Tstr_eval _ -> []
527 | Tstr_value(_, vbs) ->
528 read_value_bindings env parent vbs
529 | Tstr_primitive vd ->
530 [Cmti.read_value_description env parent vd]
531#if OCAML_VERSION < (4,3,0)
532 | Tstr_type (decls) ->
533 let rec_flag = Ordinary in
534#else
535 | Tstr_type (rec_flag, decls) ->
536 let rec_flag =
537 match rec_flag with
538 | Recursive -> Ordinary
539 | Nonrecursive -> Nonrec
540 in
541#endif
542 Cmti.read_type_declarations env parent rec_flag decls
543 | Tstr_typext tyext ->
544 [TypExt (read_type_extension env parent tyext)]
545 | Tstr_exception ext ->
546 let ext =
547#if OCAML_VERSION >= (4,8,0)
548 Cmi.read_exception env parent ext.tyexn_constructor.ext_id ext.tyexn_constructor.ext_type
549#else
550 Cmi.read_exception env parent ext.ext_id ext.ext_type
551#endif
552 in
553 [Exception ext]
554 | Tstr_module mb -> begin
555 match read_module_binding env parent mb with
556 | Some mb ->
557 [Module (Ordinary, mb)]
558 | None -> []
559 end
560 | Tstr_recmodule mbs ->
561 read_module_bindings env parent mbs
562 | Tstr_modtype mtd ->
563 [ModuleType (Cmti.read_module_type_declaration env parent mtd)]
564 | Tstr_open o ->
565 [Open (read_open env parent o)]
566 | Tstr_include incl ->
567 read_include env parent incl
568 | Tstr_class cls ->
569 let cls = List.map
570#if OCAML_VERSION < (4,3,0)
571 (* NOTE(@ostera): remember the virtual flag was removed post 4.02 *)
572 (fun (cl, _, _) -> cl)
573#else
574 (fun (cl, _) -> cl)
575#endif
576 cls in
577 read_class_declarations env parent cls
578 | Tstr_class_type cltyps ->
579 let cltyps = List.map (fun (_, _, clty) -> clty) cltyps in
580 Cmti.read_class_type_declarations env parent cltyps
581 | Tstr_attribute attr ->
582 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
583 match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
584 | None -> []
585 | Some doc -> [Comment doc]
586
587and read_include env parent incl =
588 let open Include in
589 let loc = Doc_attr.read_location incl.incl_loc in
590 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
591 let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
592 let decl_modty =
593#if defined OXCAML
594 match unwrap_module_expr_desc incl.incl_mod.mod_desc, incl.incl_kind with
595 | _, (Tincl_functor _ | Tincl_gen_functor _) ->
596 (* TODO: Handle [include functor] *)
597 None
598 | Tmod_ident(p, _), Tincl_structure ->
599#else
600 match unwrap_module_expr_desc incl.incl_mod.mod_desc with
601 | Tmod_ident(p, _) ->
602#endif
603 let p = Env.Path.read_module env.ident_env p in
604 Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p))
605 | _ ->
606 let mty = read_module_expr env parent container incl.incl_mod in
607 umty_of_mty mty
608 in
609 let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
610 let expansion = { content; shadowed; } in
611 match decl_modty with
612 | Some m ->
613 let decl = ModuleType m in
614 [Include {parent; doc; decl; expansion; expanded = false; status; strengthened=None; loc }]
615 | _ ->
616 content.items
617
618and read_open env parent o =
619 let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
620 let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container o.open_attributes in
621 #if OCAML_VERSION >= (4,8,0)
622 let signature = o.open_bound_items in
623 #else
624 let signature = [] in
625 #endif
626 let expansion, _ = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature signature) in
627 Open.{expansion; doc}
628
629and read_structure :
630 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
631 _ * 'tags =
632 fun internal_tags env parent str ->
633 let e' = Env.add_structure_tree_items parent str env.ident_env in
634 let env = { env with ident_env=e' } in
635 let items, (doc, doc_post), tags =
636 let classify item =
637 match item.str_desc with
638 | Tstr_open _ -> Some `Open
639 | Tstr_attribute attr -> Some (`Attribute attr)
640 | _ -> None
641 in
642 Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent str.str_items
643 in
644 let items =
645 List.fold_left
646 (fun items item ->
647 List.rev_append (read_structure_item env parent item) items)
648 [] items
649 |> List.rev
650 in
651 match doc_post with
652 | { elements = [] ; _} ->
653 ({ Signature.items; compiled = false; removed = []; doc }, tags)
654 | _ ->
655 ({ Signature.items = Comment (`Docs doc_post) :: items; compiled=false; removed = []; doc }, tags)
656
657let read_implementation root name ~warnings_tag impl =
658 let id =
659 Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name)
660 in
661 let sg, canonical =
662 read_structure Odoc_model.Semantics.Expect_canonical
663 { ident_env = Env.empty (); warnings_tag }
664 id impl
665 in
666 let canonical =
667 match canonical with
668 | None -> None
669 | Some s -> Some (Doc_attr.conv_canonical_module s)
670 in
671 (id, sg, canonical)
672
673let _ = Cmti.read_module_expr := read_module_expr