?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Sys.Signals module for a Variant type of signals (and a set_signal function that...
[ocaml.git] / ocamldoc / odoc_sig.ml
blob36b3b1411367eb1a4a17dd0271a94bc3aa8473aa
1 (***********************************************************************)
2 (* OCamldoc *)
3 (* *)
4 (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
5 (* *)
6 (* Copyright 2001 Institut National de Recherche en Informatique et *)
7 (* en Automatique. All rights reserved. This file is distributed *)
8 (* under the terms of the Q Public License version 1.0. *)
9 (* *)
10 (***********************************************************************)
11
12 (* $Id$ *)
13
14 (** Analysis of interface files. *)
15
16 open Misc
17 open Asttypes
18 open Types
19 open Typedtree
20 open Path
21
22 let print_DEBUG s = print_string s ; print_newline ();;
23
24 module Name = Odoc_name
25 open Odoc_parameter
26 open Odoc_value
27 open Odoc_type
28 open Odoc_exception
29 open Odoc_class
30 open Odoc_module
31 open Odoc_types
32
33 module Signature_search =
34 struct
35 type ele =
36 | M of string
37 | MT of string
38 | V of string
39 | T of string
40 | C of string
41 | CT of string
42 | E of string
43 | ER of string
44 | P of string
45
46 type tab = (ele, Types.signature_item) Hashtbl.t
47
48 let add_to_hash table signat =
49 match signat with
50 Types.Tsig_value (ident, _) ->
51 Hashtbl.add table (V (Name.from_ident ident)) signat
52 | Types.Tsig_exception (ident, _) ->
53 Hashtbl.add table (E (Name.from_ident ident)) signat
54 | Types.Tsig_type (ident, _, _) ->
55 Hashtbl.add table (T (Name.from_ident ident)) signat
56 | Types.Tsig_class (ident, _, _) ->
57 Hashtbl.add table (C (Name.from_ident ident)) signat
58 | Types.Tsig_cltype (ident, _, _) ->
59 Hashtbl.add table (CT (Name.from_ident ident)) signat
60 | Types.Tsig_module (ident, _, _) ->
61 Hashtbl.add table (M (Name.from_ident ident)) signat
62 | Types.Tsig_modtype (ident,_) ->
63 Hashtbl.add table (MT (Name.from_ident ident)) signat
64
65 let table signat =
66 let t = Hashtbl.create 13 in
67 List.iter (add_to_hash t) signat;
68 t
69
70 let search_value table name =
71 match Hashtbl.find table (V name) with
72 | (Types.Tsig_value (_, val_desc)) -> val_desc.Types.val_type
73 | _ -> assert false
74
75 let search_exception table name =
76 match Hashtbl.find table (E name) with
77 | (Types.Tsig_exception (_, type_expr_list)) ->
78 type_expr_list
79 | _ -> assert false
80
81 let search_type table name =
82 match Hashtbl.find table (T name) with
83 | (Types.Tsig_type (_, type_decl, _)) -> type_decl
84 | _ -> assert false
85
86 let search_class table name =
87 match Hashtbl.find table (C name) with
88 | (Types.Tsig_class (_, class_decl, _)) -> class_decl
89 | _ -> assert false
90
91 let search_class_type table name =
92 match Hashtbl.find table (CT name) with
93 | (Types.Tsig_cltype (_, cltype_decl, _)) -> cltype_decl
94 | _ -> assert false
95
96 let search_module table name =
97 match Hashtbl.find table (M name) with
98 | (Types.Tsig_module (ident, module_type, _)) -> module_type
99 | _ -> assert false
100
101 let search_module_type table name =
102 match Hashtbl.find table (MT name) with
103 | (Types.Tsig_modtype (_, Types.Tmodtype_manifest module_type)) ->
104 Some module_type
105 | (Types.Tsig_modtype (_, Types.Tmodtype_abstract)) ->
106 None
107 | _ -> assert false
108
109 let search_attribute_type name class_sig =
110 let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
111 type_expr
112
113 let search_method_type name class_sig =
114 let fields = Odoc_misc.get_fields class_sig.Types.cty_self in
115 List.assoc name fields
116 end
117
118 module type Info_retriever =
119 sig
120 val all_special : string -> string -> int * (Odoc_types.info list)
121 val blank_line_outside_simple : string -> string -> bool
122 val just_after_special : string -> string -> (int * Odoc_types.info option)
123 val first_special : string -> string -> (int * Odoc_types.info option)
124 val get_comments :
125 (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list)
126 end
127
128 module Analyser =
129 functor (My_ir : Info_retriever) ->
130 struct
131 (** This variable is used to load a file as a string and retrieve characters from it.*)
132 let file = ref ""
133 (** The name of the analysed file. *)
134 let file_name = ref ""
135
136 (** This function takes two indexes (start and end) and return the string
137 corresponding to the indexes in the file global variable. The function
138 prepare_file must have been called to fill the file global variable.*)
139 let get_string_of_file the_start the_end =
140 try
141 let s = String.sub !file the_start (the_end-the_start) in
142 s
143 with
144 Invalid_argument _ ->
145 ""
146
147 (** This function loads the given file in the file global variable,
148 and sets file_name.*)
149 let prepare_file f input_f =
150 try
151 let s = Odoc_misc.input_file_as_string input_f in
152 file := s;
153 file_name := f
154 with
155 e ->
156 file := "";
157 raise e
158
159 (** The function used to get the comments in a class. *)
160 let get_comments_in_class pos_start pos_end =
161 My_ir.get_comments (fun t -> Class_comment t)
162 !file_name
163 (get_string_of_file pos_start pos_end)
164
165 (** The function used to get the comments in a module. *)
166 let get_comments_in_module pos_start pos_end =
167 My_ir.get_comments (fun t -> Element_module_comment t)
168 !file_name
169 (get_string_of_file pos_start pos_end)
170
171 let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
172
173 let name_comment_from_type_kind pos_end pos_limit tk =
174 match tk with
175 Parsetree.Ptype_abstract | Parsetree.Ptype_private ->
176 (0, [])
177 | Parsetree.Ptype_variant (cons_core_type_list_list, _) ->
178 let rec f acc cons_core_type_list_list =
179 match cons_core_type_list_list with
180 [] ->
181 (0, acc)
182 | (name, core_type_list, loc) :: [] ->
183 let s = get_string_of_file
184 loc.Location.loc_end.Lexing.pos_cnum
185 pos_limit
186 in
187 let (len, comment_opt) = My_ir.just_after_special !file_name s in
188 (len, acc @ [ (name, comment_opt) ])
189 | (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
190 :: q ->
191 let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
192 let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
193 let s = get_string_of_file pos_end_first pos_start_second in
194 let (_,comment_opt) = My_ir.just_after_special !file_name s in
195 f (acc @ [name, comment_opt])
196 ((name2, core_type_list2, loc2) :: q)
197 in
198 f [] cons_core_type_list_list
199
200 | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) ->
201 let rec f = function
202 [] ->
203 []
204 | (name, _, ct, xxloc) :: [] ->
205 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
206 let s = get_string_of_file pos pos_end in
207 let (_,comment_opt) = My_ir.just_after_special !file_name s in
208 [name, comment_opt]
209 | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q ->
210 let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
211 let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
212 let s = get_string_of_file pos pos2 in
213 let (_,comment_opt) = My_ir.just_after_special !file_name s in
214 (name, comment_opt) :: (f (ele2 :: q))
215 in
216 (0, f name_mutable_type_list)
217
218 let get_type_kind env name_comment_list type_kind =
219 match type_kind with
220 Types.Type_abstract ->
221 Odoc_type.Type_abstract
222
223 | Types.Type_variant (l, priv) ->
224 let f (constructor_name, type_expr_list) =
225 let comment_opt =
226 try
227 match List.assoc constructor_name name_comment_list with
228 None -> None
229 | Some d -> d.Odoc_types.i_desc
230 with Not_found -> None
231 in
232 {
233 vc_name = constructor_name ;
234 vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
235 vc_text = comment_opt
236 }
237 in
238 Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private)
239
240 | Types.Type_record (l, _, priv) ->
241 let f (field_name, mutable_flag, type_expr) =
242 let comment_opt =
243 try
244 match List.assoc field_name name_comment_list with
245 None -> None
246 | Some d -> d.Odoc_types.i_desc
247 with Not_found -> None
248 in
249 {
250 rf_name = field_name ;
251 rf_mutable = mutable_flag = Mutable ;
252 rf_type = Odoc_env.subst_type env type_expr ;
253 rf_text = comment_opt
254 }
255 in
256 Odoc_type.Type_record (List.map f l, priv = Asttypes.Private)
257
258 (** Analysis of the elements of a class, from the information in the parsetree and in the class
259 signature. @return the couple (inherited_class list, elements).*)
260 let analyse_class_elements env current_class_name last_pos pos_limit
261 class_type_field_list class_signature =
262 print_DEBUG "Types.Tcty_signature class_signature";
263 let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
264 Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
265 print_DEBUG ("Type de la classe "^current_class_name^" : ");
266 print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
267 let get_pos_limit2 q =
268 match q with
269 [] -> pos_limit
270 | ele2 :: _ ->
271 match ele2 with
272 Parsetree.Pctf_val (_, _, _, _, loc)
273 | Parsetree.Pctf_virt (_, _, _, loc)
274 | Parsetree.Pctf_meth (_, _, _, loc)
275 | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
276 | Parsetree.Pctf_inher class_type ->
277 class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
278 in
279 let get_method name comment_opt private_flag loc q =
280 let complete_name = Name.concat current_class_name name in
281 let typ =
282 try Signature_search.search_method_type name class_signature
283 with Not_found ->
284 raise (Failure (Odoc_messages.method_type_not_found current_class_name name))
285 in
286 let subst_typ = Odoc_env.subst_type env typ in
287 let met =
288 {
289 met_value =
290 {
291 val_name = complete_name ;
292 val_info = comment_opt ;
293 val_type = subst_typ ;
294 val_recursive = false ;
295 val_parameters = Odoc_value.dummy_parameter_list subst_typ ;
296 val_code = None ;
297 val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) };
298 } ;
299 met_private = private_flag = Asttypes.Private ;
300 met_virtual = false ;
301 }
302 in
303 let pos_limit2 = get_pos_limit2 q in
304 let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
305 let (maybe_more, info_after_opt) =
306 My_ir.just_after_special
307 !file_name
308 (get_string_of_file pos_end pos_limit2)
309 in
310 met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ;
311 (* update the parameter description *)
312 Odoc_value.update_value_parameters_text met.met_value;
313 (met, maybe_more)
314 in
315 let rec f last_pos class_type_field_list =
316 match class_type_field_list with
317 [] ->
318 let s = get_string_of_file last_pos pos_limit in
319 let (_, ele_coms) = My_ir.all_special !file_name s in
320 let ele_comments =
321 List.fold_left
322 (fun acc -> fun sc ->
323 match sc.Odoc_types.i_desc with
324 None ->
325 acc
326 | Some t ->
327 acc @ [Class_comment t])
328 []
329 ele_coms
330 in
331 ([], ele_comments)
332
333 | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
334 (* of (string * mutable_flag * core_type option * Location.t)*)
335 let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
336 let complete_name = Name.concat current_class_name name in
337 let typ =
338 try Signature_search.search_attribute_type name class_signature
339 with Not_found ->
340 raise (Failure (Odoc_messages.attribute_type_not_found current_class_name name))
341 in
342 let subst_typ = Odoc_env.subst_type env typ in
343 let att =
344 {
345 att_value =
346 {
347 val_name = complete_name ;
348 val_info = comment_opt ;
349 val_type = subst_typ;
350 val_recursive = false ;
351 val_parameters = [] ;
352 val_code = None ;
353 val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ;
354 } ;
355 att_mutable = mutable_flag = Asttypes.Mutable ;
356 }
357 in
358 let pos_limit2 = get_pos_limit2 q in
359 let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
360 let (maybe_more, info_after_opt) =
361 My_ir.just_after_special
362 !file_name
363 (get_string_of_file pos_end pos_limit2)
364 in
365 att.att_value.val_info <- merge_infos att.att_value.val_info info_after_opt ;
366 let (inher_l, eles) = f (pos_end + maybe_more) q in
367 (inher_l, eles_comments @ ((Class_attribute att) :: eles))
368
369 | Parsetree.Pctf_virt (name, private_flag, _, loc) :: q ->
370 (* of (string * private_flag * core_type * Location.t) *)
371 let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
372 let (met, maybe_more) = get_method name comment_opt private_flag loc q in
373 let met2 = { met with met_virtual = true } in
374 let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
375 (inher_l, eles_comments @ ((Class_method met2) :: eles))
376
377 | Parsetree.Pctf_meth (name, private_flag, _, loc) :: q ->
378 (* of (string * private_flag * core_type * Location.t) *)
379 let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
380 let (met, maybe_more) = get_method name comment_opt private_flag loc q in
381 let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
382 (inher_l, eles_comments @ ((Class_method met) :: eles))
383
384 | (Parsetree.Pctf_cstr (_, _, loc)) :: q ->
385 (* of (core_type * core_type * Location.t) *)
386 (* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *)
387 let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
388 let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
389 (inher_l, eles_comments @ eles)
390
391 | Parsetree.Pctf_inher class_type :: q ->
392 let loc = class_type.Parsetree.pcty_loc in
393 let (comment_opt, eles_comments) =
394 get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum
395 in
396 let pos_limit2 = get_pos_limit2 q in
397 let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
398 let (maybe_more, info_after_opt) =
399 My_ir.just_after_special
400 !file_name
401 (get_string_of_file pos_end pos_limit2)
402 in
403 let comment_opt2 = merge_infos comment_opt info_after_opt in
404 let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in
405 let inh =
406 match class_type.Parsetree.pcty_desc with
407 Parsetree.Pcty_constr (longident, _) ->
408 (*of Longident.t * core_type list*)
409 let name = Name.from_longident longident in
410 let ic =
411 {
412 ic_name = Odoc_env.full_class_or_class_type_name env name ;
413 ic_class = None ;
414 ic_text = text_opt ;
415 }
416 in
417 ic
418
419 | Parsetree.Pcty_signature _
420 | Parsetree.Pcty_fun _ ->
421 (* we don't have a name for the class signature, so we call it "object ... end" *)
422 {
423 ic_name = Odoc_messages.object_end ;
424 ic_class = None ;
425 ic_text = text_opt ;
426 }
427 in
428 let (inher_l, eles) = f (pos_end + maybe_more) q in
429 (inh :: inher_l , eles_comments @ eles)
430 in
431 f last_pos class_type_field_list
432
433 (** Analyse of a .mli parse tree, to get the corresponding elements.
434 last_pos is the position of the first character which may be used to look for special comments.
435 *)
436 let rec analyse_parsetree env signat current_module_name last_pos pos_limit sig_item_list =
437 let table = Signature_search.table signat in
438 (* we look for the comment of each item then analyse the item *)
439 let rec f acc_eles acc_env last_pos = function
440 [] ->
441 let s = get_string_of_file last_pos pos_limit in
442 let (_, ele_coms) = My_ir.all_special !file_name s in
443 let ele_comments =
444 List.fold_left
445 (fun acc -> fun sc ->
446 match sc.Odoc_types.i_desc with
447 None ->
448 acc
449 | Some t ->
450 acc @ [Element_module_comment t])
451 []
452 ele_coms
453 in
454 acc_eles @ ele_comments
455
456 | ele :: q ->
457 let (assoc_com, ele_comments) = get_comments_in_module
458 last_pos
459 ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
460 in
461 let (maybe_more, new_env, elements) = analyse_signature_item_desc
462 acc_env
463 signat
464 table
465 current_module_name
466 ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
467 ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum
468 (match q with
469 [] -> pos_limit
470 | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
471 )
472 assoc_com
473 ele.Parsetree.psig_desc
474 in
475 f (acc_eles @ (ele_comments @ elements))
476 new_env
477 (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more)
478 (* for the comments of constructors in types,
479 which are after the constructor definition and can
480 go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *)
481 q
482 in
483 f [] env last_pos sig_item_list
484
485 (** Analyse the given signature_item_desc to create the corresponding module element
486 (with the given attached comment).*)
487 and analyse_signature_item_desc env signat table current_module_name
488 pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc =
489 match sig_item_desc with
490 Parsetree.Psig_value (name_pre, value_desc) ->
491 let type_expr =
492 try Signature_search.search_value table name_pre
493 with Not_found ->
494 raise (Failure (Odoc_messages.value_not_found current_module_name name_pre))
495 in
496 let name = Name.parens_if_infix name_pre in
497 let subst_typ = Odoc_env.subst_type env type_expr in
498 let v =
499 {
500 val_name = Name.concat current_module_name name ;
501 val_info = comment_opt ;
502 val_type = subst_typ ;
503 val_recursive = false ;
504 val_parameters = Odoc_value.dummy_parameter_list subst_typ ;
505 val_code = None ;
506 val_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele)}
507 }
508 in
509 let (maybe_more, info_after_opt) =
510 My_ir.just_after_special
511 !file_name
512 (get_string_of_file pos_end_ele pos_limit)
513 in
514 v.val_info <- merge_infos v.val_info info_after_opt ;
515 (* update the parameter description *)
516 Odoc_value.update_value_parameters_text v;
517
518 let new_env = Odoc_env.add_value env v.val_name in
519 (maybe_more, new_env, [ Element_value v ])
520
521 | Parsetree.Psig_exception (name, exception_decl) ->
522 let types_excep_decl =
523 try Signature_search.search_exception table name
524 with Not_found ->
525 raise (Failure (Odoc_messages.exception_not_found current_module_name name))
526 in
527 let e =
528 {
529 ex_name = Name.concat current_module_name name ;
530 ex_info = comment_opt ;
531 ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ;
532 ex_alias = None ;
533 ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
534 ex_code =
535 (
536 if !Odoc_args.keep_code then
537 Some (get_string_of_file pos_start_ele pos_end_ele)
538 else
539 None
540 ) ;
541 }
542 in
543 let (maybe_more, info_after_opt) =
544 My_ir.just_after_special
545 !file_name
546 (get_string_of_file pos_end_ele pos_limit)
547 in
548 e.ex_info <- merge_infos e.ex_info info_after_opt ;
549 let new_env = Odoc_env.add_exception env e.ex_name in
550 (maybe_more, new_env, [ Element_exception e ])
551
552 | Parsetree.Psig_type name_type_decl_list ->
553 (* we start by extending the environment *)
554 let new_env =
555 List.fold_left
556 (fun acc_env -> fun (name, _) ->
557 let complete_name = Name.concat current_module_name name in
558 Odoc_env.add_type acc_env complete_name
559 )
560 env
561 name_type_decl_list
562 in
563 let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list =
564 match name_type_decl_list with
565 [] ->
566 (acc_maybe_more, [])
567 | (name, type_decl) :: q ->
568 let (assoc_com, ele_comments) =
569 if first then
570 (comment_opt, [])
571 else
572 get_comments_in_module
573 last_pos
574 type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
575 in
576 let pos_limit2 =
577 match q with
578 [] -> pos_limit
579 | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
580 in
581 let (maybe_more, name_comment_list) =
582 name_comment_from_type_kind
583 type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum
584 pos_limit2
585 type_decl.Parsetree.ptype_kind
586 in
587 print_DEBUG ("Type "^name^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c));
588 let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in
589 List.iter f_DEBUG name_comment_list;
590 (* get the information for the type in the signature *)
591 let sig_type_decl =
592 try Signature_search.search_type table name
593 with Not_found ->
594 raise (Failure (Odoc_messages.type_not_found current_module_name name))
595 in
596 (* get the type kind with the associated comments *)
597 let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in
598 let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
599 let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in
600 (* associate the comments to each constructor and build the [Type.t_type] *)
601 let new_type =
602 {
603 ty_name = Name.concat current_module_name name ;
604 ty_info = assoc_com ;
605 ty_parameters =
606 List.map2 (fun p (co,cn,_) ->
607 (Odoc_env.subst_type new_env p,
608 co, cn)
609 )
610 sig_type_decl.Types.type_params
611 sig_type_decl.Types.type_variance;
612 ty_kind = type_kind ;
613 ty_manifest =
614 (match sig_type_decl.Types.type_manifest with
615 None -> None
616 | Some t -> Some (Odoc_env.subst_type new_env t));
617 ty_loc =
618 { loc_impl = None ;
619 loc_inter = Some (!file_name,loc_start) ;
620 };
621 ty_code =
622 (
623 if !Odoc_args.keep_code then
624 Some (get_string_of_file loc_start new_end)
625 else
626 None
627 ) ;
628 }
629 in
630 let (maybe_more2, info_after_opt) =
631 My_ir.just_after_special
632 !file_name
633 (get_string_of_file new_end pos_limit2)
634 in
635 new_type.ty_info <- merge_infos new_type.ty_info info_after_opt ;
636 let (new_maybe_more, eles) = f
637 (maybe_more + maybe_more2)
638 (new_end + maybe_more2)
639 q
640 in
641 (new_maybe_more, (ele_comments @ [Element_type new_type]) @ eles)
642 in
643 let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in
644 (maybe_more, new_env, types)
645
646 | Parsetree.Psig_open _ -> (* A VOIR *)
647 let ele_comments = match comment_opt with
648 None -> []
649 | Some i ->
650 match i.i_desc with
651 None -> []
652 | Some t -> [Element_module_comment t]
653 in
654 (0, env, ele_comments)
655
656 | Parsetree.Psig_module (name, module_type) ->
657 let complete_name = Name.concat current_module_name name in
658 (* get the the module type in the signature by the module name *)
659 let sig_module_type =
660 try Signature_search.search_module table name
661 with Not_found ->
662 raise (Failure (Odoc_messages.module_not_found current_module_name name))
663 in
664 let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
665 let code_intf =
666 if !Odoc_args.keep_code then
667 let loc = module_type.Parsetree.pmty_loc in
668 let st = loc.Location.loc_start.Lexing.pos_cnum in
669 let en = loc.Location.loc_end.Lexing.pos_cnum in
670 Some (get_string_of_file st en)
671 else
672 None
673 in
674 let new_module =
675 {
676 m_name = complete_name ;
677 m_type = sig_module_type;
678 m_info = comment_opt ;
679 m_is_interface = true ;
680 m_file = !file_name ;
681 m_kind = module_kind ;
682 m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
683 m_top_deps = [] ;
684 m_code = None ;
685 m_code_intf = code_intf ;
686 m_text_only = false ;
687 }
688 in
689 let (maybe_more, info_after_opt) =
690 My_ir.just_after_special
691 !file_name
692 (get_string_of_file pos_end_ele pos_limit)
693 in
694 new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
695 let new_env = Odoc_env.add_module env new_module.m_name in
696 let new_env2 =
697 match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
698 Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s
699 | _ -> new_env
700 in
701 (maybe_more, new_env2, [ Element_module new_module ])
702
703 | Parsetree.Psig_recmodule decls ->
704 (* we start by extending the environment *)
705 let new_env =
706 List.fold_left
707 (fun acc_env -> fun (name, _) ->
708 let complete_name = Name.concat current_module_name name in
709 let e = Odoc_env.add_module acc_env complete_name in
710 (* get the information for the module in the signature *)
711 let sig_module_type =
712 try Signature_search.search_module table name
713 with Not_found ->
714 raise (Failure (Odoc_messages.module_not_found current_module_name name))
715 in
716 match sig_module_type with
717 (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
718 Types.Tmty_signature s ->
719 Odoc_env.add_signature e complete_name ~rel: name s
720 | _ ->
721 print_DEBUG "not a Tmty_signature";
722 e
723 )
724 env
725 decls
726 in
727 let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list =
728 match name_mtype_list with
729 [] ->
730 (acc_maybe_more, [])
731 | (name, modtype) :: q ->
732 let complete_name = Name.concat current_module_name name in
733 let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
734 let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
735 let (assoc_com, ele_comments) =
736 if first then
737 (comment_opt, [])
738 else
739 get_comments_in_module
740 last_pos
741 loc_start
742 in
743 let pos_limit2 =
744 match q with
745 [] -> pos_limit
746 | (_, mty) :: _ -> mty.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
747 in
748 (* get the information for the module in the signature *)
749 let sig_module_type =
750 try Signature_search.search_module table name
751 with Not_found ->
752 raise (Failure (Odoc_messages.module_not_found current_module_name name))
753 in
754 (* associate the comments to each constructor and build the [Type.t_type] *)
755 let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
756 let code_intf =
757 if !Odoc_args.keep_code then
758 let loc = modtype.Parsetree.pmty_loc in
759 let st = loc.Location.loc_start.Lexing.pos_cnum in
760 let en = loc.Location.loc_end.Lexing.pos_cnum in
761 Some (get_string_of_file st en)
762 else
763 None
764 in
765 let new_module =
766 {
767 m_name = complete_name ;
768 m_type = sig_module_type;
769 m_info = assoc_com ;
770 m_is_interface = true ;
771 m_file = !file_name ;
772 m_kind = module_kind ;
773 m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
774 m_top_deps = [] ;
775 m_code = None ;
776 m_code_intf = code_intf ;
777 m_text_only = false ;
778 }
779 in
780 let (maybe_more, info_after_opt) =
781 My_ir.just_after_special
782 !file_name
783 (get_string_of_file loc_end pos_limit2)
784 in
785 new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
786
787 let (maybe_more2, eles) = f
788 maybe_more
789 (loc_end + maybe_more)
790 q
791 in
792 (maybe_more2, (ele_comments @ [Element_module new_module]) @ eles)
793 in
794 let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in
795 (maybe_more, new_env, mods)
796
797 | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_abstract) ->
798 let sig_mtype =
799 try Signature_search.search_module_type table name
800 with Not_found ->
801 raise (Failure (Odoc_messages.module_type_not_found current_module_name name))
802 in
803 let complete_name = Name.concat current_module_name name in
804 let mt =
805 {
806 mt_name = complete_name ;
807 mt_info = comment_opt ;
808 mt_type = sig_mtype ;
809 mt_is_interface = true ;
810 mt_file = !file_name ;
811 mt_kind = None ;
812 mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
813 }
814 in
815 let (maybe_more, info_after_opt) =
816 My_ir.just_after_special
817 !file_name
818 (get_string_of_file pos_end_ele pos_limit)
819 in
820 mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
821 let new_env = Odoc_env.add_module_type env mt.mt_name in
822 (maybe_more, new_env, [ Element_module_type mt ])
823
824 | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_manifest module_type) ->
825 let complete_name = Name.concat current_module_name name in
826 let sig_mtype_opt =
827 try Signature_search.search_module_type table name
828 with Not_found ->
829 raise (Failure (Odoc_messages.module_type_not_found current_module_name name))
830 in
831 let module_type_kind =
832 match sig_mtype_opt with
833 | Some sig_mtype -> Some (analyse_module_type_kind env complete_name module_type sig_mtype)
834 | None -> None
835 in
836 let mt =
837 {
838 mt_name = complete_name ;
839 mt_info = comment_opt ;
840 mt_type = sig_mtype_opt ;
841 mt_is_interface = true ;
842 mt_file = !file_name ;
843 mt_kind = module_type_kind ;
844 mt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
845 }
846 in
847 let (maybe_more, info_after_opt) =
848 My_ir.just_after_special
849 !file_name
850 (get_string_of_file pos_end_ele pos_limit)
851 in
852 mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
853 let new_env = Odoc_env.add_module_type env mt.mt_name in
854 let new_env2 =
855 match sig_mtype_opt with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
856 Some (Types.Tmty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
857 | _ -> new_env
858 in
859 (maybe_more, new_env2, [ Element_module_type mt ])
860
861 | Parsetree.Psig_include module_type ->
862 let rec f = function
863 Parsetree.Pmty_ident longident ->
864 Name.from_longident longident
865 | Parsetree.Pmty_signature _ ->
866 "??"
867 | Parsetree.Pmty_functor _ ->
868 "??"
869 | Parsetree.Pmty_with (mt, _) ->
870 f mt.Parsetree.pmty_desc
871 in
872 let name = (f module_type.Parsetree.pmty_desc) in
873 let full_name = Odoc_env.full_module_or_module_type_name env name in
874 let im =
875 {
876 im_name = full_name ;
877 im_module = None ;
878 im_info = comment_opt;
879 }
880 in
881 (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
882
883 | Parsetree.Psig_class class_description_list ->
884 (* we start by extending the environment *)
885 let new_env =
886 List.fold_left
887 (fun acc_env -> fun class_desc ->
888 let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name in
889 Odoc_env.add_class acc_env complete_name
890 )
891 env
892 class_description_list
893 in
894 let rec f ?(first=false) acc_maybe_more last_pos class_description_list =
895 match class_description_list with
896 [] ->
897 (acc_maybe_more, [])
898 | class_desc :: q ->
899 let (assoc_com, ele_comments) =
900 if first then
901 (comment_opt, [])
902 else
903 get_comments_in_module
904 last_pos
905 class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
906 in
907 let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
908 let pos_limit2 =
909 match q with
910 [] -> pos_limit
911 | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
912 in
913 let name = class_desc.Parsetree.pci_name in
914 let complete_name = Name.concat current_module_name name in
915 let sig_class_decl =
916 try Signature_search.search_class table name
917 with Not_found ->
918 raise (Failure (Odoc_messages.class_not_found current_module_name name))
919 in
920 let sig_class_type = sig_class_decl.Types.cty_type in
921 let (parameters, class_kind) =
922 analyse_class_kind
923 new_env
924 complete_name
925 class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
926 class_desc.Parsetree.pci_expr
927 sig_class_type
928 in
929 let new_class =
930 {
931 cl_name = complete_name ;
932 cl_info = assoc_com ;
933 cl_type = Odoc_env.subst_class_type env sig_class_type ;
934 cl_type_parameters = sig_class_decl.Types.cty_params;
935 cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ;
936 cl_kind = class_kind ;
937 cl_parameters = parameters ;
938 cl_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
939 }
940 in
941 let (maybe_more, info_after_opt) =
942 My_ir.just_after_special
943 !file_name
944 (get_string_of_file pos_end pos_limit2)
945 in
946 new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ;
947 Odoc_class.class_update_parameters_text new_class ;
948 let (new_maybe_more, eles) =
949 f maybe_more (pos_end + maybe_more) q
950 in
951 (new_maybe_more,
952 ele_comments @ (( Element_class new_class ) :: eles))
953 in
954 let (maybe_more, eles) =
955 f ~first: true 0 pos_start_ele class_description_list
956 in
957 (maybe_more, new_env, eles)
958
959 | Parsetree.Psig_class_type class_type_declaration_list ->
960 (* we start by extending the environment *)
961 let new_env =
962 List.fold_left
963 (fun acc_env -> fun class_type_decl ->
964 let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in
965 Odoc_env.add_class_type acc_env complete_name
966 )
967 env
968 class_type_declaration_list
969 in
970 let rec f ?(first=false) acc_maybe_more last_pos class_type_description_list =
971 match class_type_description_list with
972 [] ->
973 (acc_maybe_more, [])
974 | ct_decl :: q ->
975 let (assoc_com, ele_comments) =
976 if first then
977 (comment_opt, [])
978 else
979 get_comments_in_module
980 last_pos
981 ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
982 in
983 let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
984 let pos_limit2 =
985 match q with
986 [] -> pos_limit
987 | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
988 in
989 let name = ct_decl.Parsetree.pci_name in
990 let complete_name = Name.concat current_module_name name in
991 let sig_cltype_decl =
992 try Signature_search.search_class_type table name
993 with Not_found ->
994 raise (Failure (Odoc_messages.class_type_not_found current_module_name name))
995 in
996 let sig_class_type = sig_cltype_decl.Types.clty_type in
997 let kind = analyse_class_type_kind
998 new_env
999 complete_name
1000 ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
1001 ct_decl.Parsetree.pci_expr
1002 sig_class_type
1003 in
1004 let ct =
1005 {
1006 clt_name = complete_name ;
1007 clt_info = assoc_com ;
1008 clt_type = Odoc_env.subst_class_type env sig_class_type ;
1009 clt_type_parameters = sig_cltype_decl.clty_params ;
1010 clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ;
1011 clt_kind = kind ;
1012 clt_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
1013 }
1014 in
1015 let (maybe_more, info_after_opt) =
1016 My_ir.just_after_special
1017 !file_name
1018 (get_string_of_file pos_end pos_limit2)
1019 in
1020 ct.clt_info <- merge_infos ct.clt_info info_after_opt ;
1021 let (new_maybe_more, eles) =
1022 f maybe_more (pos_end + maybe_more) q
1023 in
1024 (new_maybe_more,
1025 ele_comments @ (( Element_class_type ct) :: eles))
1026 in
1027 let (maybe_more, eles) =
1028 f ~first: true 0 pos_start_ele class_type_declaration_list
1029 in
1030 (maybe_more, new_env, eles)
1031
1032 (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
1033 and analyse_module_type_kind env current_module_name module_type sig_module_type =
1034 match module_type.Parsetree.pmty_desc with
1035 Parsetree.Pmty_ident longident ->
1036 let name =
1037 match sig_module_type with
1038 Types.Tmty_ident path -> Name.from_path path
1039 | _ -> Name.from_longident longident
1040 (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *)
1041 in
1042 Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ;
1043 mta_module = None }
1044
1045 | Parsetree.Pmty_signature ast ->
1046 (
1047 (* we must have a signature in the module type *)
1048 match sig_module_type with
1049 Types.Tmty_signature signat ->
1050 let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
1051 let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1052 let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in
1053 Module_type_struct elements
1054 | _ ->
1055 raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat")
1056 )
1057
1058 | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) ->
1059 (
1060 let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
1061 let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1062 let mp_type_code = get_string_of_file loc_start loc_end in
1063 print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
1064 match sig_module_type with
1065 Types.Tmty_functor (ident, param_module_type, body_module_type) ->
1066 let mp_kind = analyse_module_type_kind env
1067 current_module_name pmodule_type2 param_module_type
1068 in
1069 let param =
1070 {
1071 mp_name = Name.from_ident ident ;
1072 mp_type = Odoc_env.subst_module_type env param_module_type ;
1073 mp_type_code = mp_type_code ;
1074 mp_kind = mp_kind ;
1075 }
1076 in
1077 let k = analyse_module_type_kind env
1078 current_module_name
1079 module_type2
1080 body_module_type
1081 in
1082 Module_type_functor (param, k)
1083
1084 | _ ->
1085 (* if we're here something's wrong *)
1086 raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _")
1087 )
1088
1089 | Parsetree.Pmty_with (module_type2, _) ->
1090 (* of module_type * (Longident.t * with_constraint) list *)
1091 (
1092 let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1093 let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1094 let s = get_string_of_file loc_start loc_end in
1095 let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in
1096 Module_type_with (k, s)
1097 )
1098
1099 (** Analyse of a Parsetree.module_type and a Types.module_type.*)
1100 and analyse_module_kind env current_module_name module_type sig_module_type =
1101 match module_type.Parsetree.pmty_desc with
1102 Parsetree.Pmty_ident longident ->
1103 let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
1104 Module_with ( k, "" )
1105
1106 | Parsetree.Pmty_signature signature ->
1107 (
1108 match sig_module_type with
1109 Types.Tmty_signature signat ->
1110 Module_struct
1111 (analyse_parsetree
1112 env
1113 signat
1114 current_module_name
1115 module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
1116 module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum
1117 signature
1118 )
1119 | _ ->
1120 (* if we're here something's wrong *)
1121 raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat")
1122 )
1123 | Parsetree.Pmty_functor (_,pmodule_type2,module_type2) (* of string * module_type * module_type *) ->
1124 (
1125 match sig_module_type with
1126 Types.Tmty_functor (ident, param_module_type, body_module_type) ->
1127 let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
1128 let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1129 let mp_type_code = get_string_of_file loc_start loc_end in
1130 print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
1131 let mp_kind = analyse_module_type_kind env
1132 current_module_name pmodule_type2 param_module_type
1133 in
1134 let param =
1135 {
1136 mp_name = Name.from_ident ident ;
1137 mp_type = Odoc_env.subst_module_type env param_module_type ;
1138 mp_type_code = mp_type_code ;
1139 mp_kind = mp_kind ;
1140 }
1141 in
1142 let k = analyse_module_kind env
1143 current_module_name
1144 module_type2
1145 body_module_type
1146 in
1147 Module_functor (param, k)
1148
1149 | _ ->
1150 (* if we're here something's wrong *)
1151 raise (Failure "Parsetree.Pmty_functor _ but not Types.Tmty_functor _")
1152 )
1153 | Parsetree.Pmty_with (module_type2, _) ->
1154 (*of module_type * (Longident.t * with_constraint) list*)
1155 (
1156 let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1157 let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
1158 let s = get_string_of_file loc_start loc_end in
1159 let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in
1160 Module_with (k, s)
1161 )
1162
1163 (** Analyse of a Parsetree.class_type and a Types.class_type to return a couple
1164 (class parameters, class_kind).*)
1165 and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type =
1166 match parse_class_type.Parsetree.pcty_desc, sig_class_type with
1167 (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),
1168 Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
1169 print_DEBUG "Tcty_constr _";
1170 let path_name = Name.from_path p in
1171 let name = Odoc_env.full_class_or_class_type_name env path_name in
1172 let k =
1173 Class_constr
1174 {
1175 cco_name = name ;
1176 cco_class = None ;
1177 cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list
1178 }
1179 in
1180 ([], k)
1181
1182 | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) ->
1183 print_DEBUG "Types.Tcty_signature class_signature";
1184 let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
1185 Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
1186 print_DEBUG ("Type de la classe "^current_class_name^" : ");
1187 print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
1188 (* we get the elements of the class in class_type_field_list *)
1189 let (inher_l, ele) = analyse_class_elements env current_class_name
1190 last_pos
1191 parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
1192 class_type_field_list
1193 class_signature
1194 in
1195 ([], Class_structure (inher_l, ele))
1196
1197 | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
1198 (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
1199 (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *)
1200 if parse_label = label then
1201 (
1202 let new_param = Simple_name
1203 {
1204 sn_name = Btype.label_name label ;
1205 sn_type = Odoc_env.subst_type env type_expr ;
1206 sn_text = None ; (* will be updated when the class will be created *)
1207 }
1208 in
1209 let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in
1210 ( (new_param :: l), k )
1211 )
1212 else
1213 (
1214 raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
1215 )
1216
1217 | _ ->
1218 raise (Failure "analyse_class_kind pas de correspondance dans le match")
1219
1220 (** Analyse of a Parsetree.class_type and a Types.class_type to return a class_type_kind.*)
1221 and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type =
1222 match parse_class_type.Parsetree.pcty_desc, sig_class_type with
1223 (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),
1224 Types.Tcty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) ->
1225 print_DEBUG "Tcty_constr _";
1226 let k =
1227 Class_type
1228 {
1229 cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ;
1230 cta_class = None ;
1231 cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list
1232 }
1233 in
1234 k
1235
1236 | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) ->
1237 print_DEBUG "Types.Tcty_signature class_signature";
1238 let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
1239 Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
1240 print_DEBUG ("Type de la classe "^current_class_name^" : ");
1241 print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
1242 (* we get the elements of the class in class_type_field_list *)
1243 let (inher_l, ele) = analyse_class_elements env current_class_name
1244 last_pos
1245 parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
1246 class_type_field_list
1247 class_signature
1248 in
1249 Class_signature (inher_l, ele)
1250
1251 | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
1252 raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Tcty_fun (...)")
1253 (*
1254 | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),
1255 Types.Tcty_signature class_signature) ->
1256 (* A VOIR : c'est pour le cas des contraintes de classes :
1257 class type cons = object
1258 method m : int
1259 end
1260
1261 class ['a] maxou x =
1262 (object
1263 val a = (x : 'a)
1264 method m = a
1265 end : cons )
1266 ^^^^^^
1267 *)
1268 let k =
1269 Class_type
1270 {
1271 cta_name = Odoc_env.full_class_name env (Name.from_longident longident) ;
1272 cta_class = None ;
1273 cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list (* ?? *)
1274 }
1275 in
1276 ([], k)
1277 *)
1278 | _ ->
1279 raise (Failure "analyse_class_type_kind pas de correspondance dans le match")
1280
1281 let analyse_signature source_file input_file
1282 (ast : Parsetree.signature) (signat : Types.signature) =
1283 let complete_source_file =
1284 try
1285 let curdir = Sys.getcwd () in
1286 let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in
1287 Sys.chdir dirname ;
1288 let complete = Filename.concat (Sys.getcwd ()) basename in
1289 Sys.chdir curdir ;
1290 complete
1291 with
1292 Sys_error s ->
1293 prerr_endline s ;
1294 incr Odoc_global.errors ;
1295 source_file
1296 in
1297 prepare_file complete_source_file input_file;
1298 (* We create the t_module for this file. *)
1299 let mod_name = String.capitalize
1300 (Filename.basename (try Filename.chop_extension source_file with _ -> source_file))
1301 in
1302 let (len,info_opt) = My_ir.first_special !file_name !file in
1303 let elements =
1304 analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast
1305 in
1306 let code_intf =
1307 if !Odoc_args.keep_code then
1308 Some !file
1309 else
1310 None
1311 in
1312 {
1313 m_name = mod_name ;
1314 m_type = Types.Tmty_signature signat ;
1315 m_info = info_opt ;
1316 m_is_interface = true ;
1317 m_file = !file_name ;
1318 m_kind = Module_struct elements ;
1319 m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ;
1320 m_top_deps = [] ;
1321 m_code = None ;
1322 m_code_intf = code_intf ;
1323 m_text_only = false ;
1324 }
1325
1326 end
Objective Caml