1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 2001 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16(** Cross referencing. *) 17 18open Odoc_module 19open Odoc_class 20open Odoc_extension 21open Odoc_exception 22open Odoc_types 23open Odoc_value 24open Odoc_type 25open Odoc_parameter 26 27(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3, 28 in order to associate the element with complete information. *) 29 30(** The module used to keep what refs were modified. *) 31module S = Set.Make 32 ( 33 struct type t = string * ref_kind option 34 let compare = Pervasives.compare 35 end 36 ) 37 38let verified_refs = ref S.empty 39 40let add_verified v = verified_refs := S.add v !verified_refs 41let was_verified v = S.mem v !verified_refs 42 43(** The module with the predicates used to get the aliased modules, classes and exceptions. *) 44module P_alias = 45 struct 46 type t = int 47 48 let p_module m _ = 49 (true, 50 match m.m_kind with 51 Module_alias _ -> true 52 | _ -> false 53 ) 54 let p_module_type mt _ = 55 (true, 56 match mt.mt_kind with 57 Some (Module_type_alias _) -> true 58 | _ -> false 59 ) 60 let p_class _ _ = (false, false) 61 let p_class_type _ _ = (false, false) 62 let p_value _ _ = false 63 let p_recfield _ _ _ = false 64 let p_const _ _ _ = false 65 let p_type _ _ = (false, false) 66 let p_extension x _ = x.xt_alias <> None 67 let p_exception e _ = e.ex_alias <> None 68 let p_attribute _ _ = false 69 let p_method _ _ = false 70 let p_section _ _ = false 71 end 72 73(** The module used to get the aliased elements. *) 74module Search_alias = Odoc_search.Search (P_alias) 75 76type alias_state = 77 | Alias_to_resolve 78 79(** Couples of module name aliases. *) 80let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create 13 ;; 81 82(** Couples of module or module type name aliases. *) 83let module_and_modtype_aliases = Hashtbl.create 13;; 84 85(** Couples of extension name aliases. *) 86let extension_aliases = Hashtbl.create 13;; 87 88(** Couples of exception name aliases. *) 89let exception_aliases = Hashtbl.create 13;; 90 91let rec build_alias_list = function 92 [] -> () 93 | (Odoc_search.Res_module m) :: q -> 94 ( 95 match m.m_kind with 96 Module_alias ma -> 97 Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); 98 Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) 99 | _ -> () 100 ); 101 build_alias_list q 102 | (Odoc_search.Res_module_type mt) :: q -> 103 ( 104 match mt.mt_kind with 105 Some (Module_type_alias mta) -> 106 Hashtbl.add module_and_modtype_aliases 107 mt.mt_name (mta.mta_name, Alias_to_resolve) 108 | _ -> () 109 ); 110 build_alias_list q 111 | (Odoc_search.Res_extension x) :: q -> 112 ( 113 match x.xt_alias with 114 None -> () 115 | Some xa -> 116 Hashtbl.add extension_aliases 117 x.xt_name (xa.xa_name,Alias_to_resolve) 118 ); 119 build_alias_list q 120 | (Odoc_search.Res_exception e) :: q -> 121 ( 122 match e.ex_alias with 123 None -> () 124 | Some ea -> 125 Hashtbl.add exception_aliases 126 e.ex_name (ea.ea_name,Alias_to_resolve) 127 ); 128 build_alias_list q 129 | _ :: q -> 130 build_alias_list q 131 132(** Retrieve the aliases for modules, module types and exceptions 133 and put them in global hash tables. *) 134let get_alias_names module_list = 135 Hashtbl.clear module_aliases; 136 Hashtbl.clear module_and_modtype_aliases; 137 Hashtbl.clear extension_aliases; 138 Hashtbl.clear exception_aliases; 139 build_alias_list (Search_alias.search module_list 0) 140 141module Map_ord = 142 struct 143 type t = string 144 let compare (x:t) y = Pervasives.compare x y 145 end 146 147module Ele_map = Map.Make (Map_ord) 148 149let known_elements = ref Ele_map.empty 150let add_known_element name k = 151 try 152 let l = Ele_map.find name !known_elements in 153 let s = Ele_map.remove name !known_elements in 154 known_elements := Ele_map.add name (k::l) s 155 with 156 Not_found -> 157 known_elements := Ele_map.add name [k] !known_elements 158 159let get_known_elements name = 160 try Ele_map.find name !known_elements 161 with Not_found -> [] 162 163let kind_name_exists kind = 164 let pred = 165 match kind with 166 RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) 167 | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) 168 | RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false) 169 | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) 170 | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) 171 | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) 172 | RK_extension -> (fun e -> match e with Odoc_search.Res_extension _ -> true | _ -> false) 173 | RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false) 174 | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) 175 | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) 176 | RK_section _ -> assert false 177 | RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false) 178 | RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false) 179 in 180 fun name -> 181 try List.exists pred (get_known_elements name) 182 with Not_found -> false 183 184let module_exists = kind_name_exists RK_module 185let module_type_exists = kind_name_exists RK_module_type 186let class_exists = kind_name_exists RK_class 187let class_type_exists = kind_name_exists RK_class_type 188let value_exists = kind_name_exists RK_value 189let type_exists = kind_name_exists RK_type 190let extension_exists = kind_name_exists RK_extension 191let exception_exists = kind_name_exists RK_exception 192let attribute_exists = kind_name_exists RK_attribute 193let method_exists = kind_name_exists RK_method 194let recfield_exists = kind_name_exists RK_recfield 195let const_exists = kind_name_exists RK_const 196 197let lookup_module name = 198 match List.find 199 (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false) 200 (get_known_elements name) 201 with 202 | Odoc_search.Res_module m -> m 203 | _ -> assert false 204 205let lookup_module_type name = 206 match List.find 207 (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false) 208 (get_known_elements name) 209 with 210 | Odoc_search.Res_module_type m -> m 211 | _ -> assert false 212 213let lookup_class name = 214 match List.find 215 (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false) 216 (get_known_elements name) 217 with 218 | Odoc_search.Res_class c -> c 219 | _ -> assert false 220 221let lookup_class_type name = 222 match List.find 223 (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false) 224 (get_known_elements name) 225 with 226 | Odoc_search.Res_class_type c -> c 227 | _ -> assert false 228 229let lookup_extension name = 230 match List.find 231 (fun k -> match k with Odoc_search.Res_extension _ -> true | _ -> false) 232 (get_known_elements name) 233 with 234 | Odoc_search.Res_extension x -> x 235 | _ -> assert false 236 237let lookup_exception name = 238 match List.find 239 (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false) 240 (get_known_elements name) 241 with 242 | Odoc_search.Res_exception e -> e 243 | _ -> assert false 244 245class scan = 246 object 247 inherit Odoc_scan.scanner 248 method! scan_value v = 249 add_known_element v.val_name (Odoc_search.Res_value v) 250 method! scan_type_recfield t f = 251 add_known_element 252 (Printf.sprintf "%s.%s" t.ty_name f.rf_name) 253 (Odoc_search.Res_recfield (t, f)) 254 method! scan_type_const t f = 255 add_known_element 256 (Printf.sprintf "%s.%s" t.ty_name f.vc_name) 257 (Odoc_search.Res_const (t, f)) 258 method! scan_type_pre t = 259 add_known_element t.ty_name (Odoc_search.Res_type t); 260 true 261 method! scan_extension_constructor x = 262 add_known_element x.xt_name (Odoc_search.Res_extension x) 263 method! scan_exception e = 264 add_known_element e.ex_name (Odoc_search.Res_exception e) 265 method! scan_attribute a = 266 add_known_element a.att_value.val_name 267 (Odoc_search.Res_attribute a) 268 method! scan_method m = 269 add_known_element m.met_value.val_name 270 (Odoc_search.Res_method m) 271 method! scan_class_pre c = 272 add_known_element c.cl_name (Odoc_search.Res_class c); 273 true 274 method! scan_class_type_pre c = 275 add_known_element c.clt_name (Odoc_search.Res_class_type c); 276 true 277 method! scan_module_pre m = 278 add_known_element m.m_name (Odoc_search.Res_module m); 279 true 280 method! scan_module_type_pre m = 281 add_known_element m.mt_name (Odoc_search.Res_module_type m); 282 true 283 284 end 285 286let init_known_elements_map module_list = 287 let c = new scan in 288 c#scan_module_list module_list 289 290 291(** The type to describe the names not found. *) 292type not_found_name = 293 | NF_mt of Name.t 294 | NF_mmt of Name.t 295 | NF_c of Name.t 296 | NF_cct of Name.t 297 | NF_xt of Name.t 298 | NF_ex of Name.t 299 300(** Functions to find and associate aliases elements. *) 301 302let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m = 303 let rec iter_kind (acc_b, acc_inc, acc_names) k = 304 match k with 305 Module_struct elements -> 306 List.fold_left 307 (associate_in_module_element module_list m.m_name) 308 (acc_b, acc_inc, acc_names) 309 elements 310 311 | Module_alias ma -> 312 ( 313 match ma.ma_module with 314 Some _ -> 315 (acc_b, acc_inc, acc_names) 316 | None -> 317 let mmt_opt = 318 try Some (Mod (lookup_module ma.ma_name)) 319 with Not_found -> 320 try Some (Modtype (lookup_module_type ma.ma_name)) 321 with Not_found -> None 322 in 323 match mmt_opt with 324 None -> (acc_b, (Name.head m.m_name) :: acc_inc, 325 (* we don't want to output warning messages for 326 "sig ... end" or "struct ... end" modules not found *) 327 (if ma.ma_name = Odoc_messages.struct_end || 328 ma.ma_name = Odoc_messages.sig_end then 329 acc_names 330 else 331 (NF_mmt ma.ma_name) :: acc_names) 332 ) 333 | Some mmt -> 334 ma.ma_module <- Some mmt ; 335 (true, acc_inc, acc_names) 336 ) 337 338 | Module_functor (_, k) -> 339 iter_kind (acc_b, acc_inc, acc_names) k 340 341 | Module_with (tk, _) -> 342 associate_in_module_type module_list (acc_b, acc_inc, acc_names) 343 { mt_name = "" ; mt_info = None ; mt_type = None ; 344 mt_is_interface = false ; mt_file = ""; mt_kind = Some tk ; 345 mt_loc = Odoc_types.dummy_loc } 346 347 | Module_apply (k1, k2) -> 348 let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k1 in 349 iter_kind (acc_b2, acc_inc2, acc_names2) k2 350 351 | Module_constraint (k, tk) -> 352 let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k in 353 associate_in_module_type module_list (acc_b2, acc_inc2, acc_names2) 354 { mt_name = "" ; mt_info = None ; mt_type = None ; 355 mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; 356 mt_loc = Odoc_types.dummy_loc } 357 358 | Module_typeof _ -> 359 (acc_b, acc_inc, acc_names) 360 361 | Module_unpack (_code, mta) -> 362 begin 363 match mta.mta_module with 364 Some _ -> 365 (acc_b, acc_inc, acc_names) 366 | None -> 367 let mt_opt = 368 try Some (lookup_module_type mta.mta_name) 369 with Not_found -> None 370 in 371 match mt_opt with 372 None -> (acc_b, (Name.head m.m_name) :: acc_inc, 373 (* we don't want to output warning messages for 374 "sig ... end" or "struct ... end" modules not found *) 375 (if mta.mta_name = Odoc_messages.struct_end || 376 mta.mta_name = Odoc_messages.sig_end then 377 acc_names 378 else 379 (NF_mt mta.mta_name) :: acc_names) 380 ) 381 | Some mt -> 382 mta.mta_module <- Some mt ; 383 (true, acc_inc, acc_names) 384 end 385 in 386 iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m.m_kind 387 388and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt = 389 let rec iter_kind (acc_b, acc_inc, acc_names) k = 390 match k with 391 Module_type_struct elements -> 392 List.fold_left 393 (associate_in_module_element module_list mt.mt_name) 394 (acc_b, acc_inc, acc_names) 395 elements 396 397 | Module_type_functor (_, k) -> 398 iter_kind (acc_b, acc_inc, acc_names) k 399 400 | Module_type_with (k, _) -> 401 iter_kind (acc_b, acc_inc, acc_names) k 402 403 | Module_type_alias mta -> 404 begin 405 match mta.mta_module with 406 Some _ -> 407 (acc_b, acc_inc, acc_names) 408 | None -> 409 let mt_opt = 410 try Some (lookup_module_type mta.mta_name) 411 with Not_found -> None 412 in 413 match mt_opt with 414 None -> (acc_b, (Name.head mt.mt_name) :: acc_inc, 415 (* we don't want to output warning messages for 416 "sig ... end" or "struct ... end" modules not found *) 417 (if mta.mta_name = Odoc_messages.struct_end || 418 mta.mta_name = Odoc_messages.sig_end then 419 acc_names 420 else 421 (NF_mt mta.mta_name) :: acc_names) 422 ) 423 | Some mt -> 424 mta.mta_module <- Some mt ; 425 (true, acc_inc, acc_names) 426 end 427 | Module_type_typeof _ -> 428 (acc_b, acc_inc, acc_names) 429 in 430 match mt.mt_kind with 431 None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 432 | Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k 433 434and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element = 435 match element with 436 Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m 437 | Element_module_type mt -> 438 associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt 439 | Element_included_module im -> 440 ( 441 match im.im_module with 442 Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 443 | None -> 444 let mmt_opt = 445 try Some (Mod (lookup_module im.im_name)) 446 with Not_found -> 447 try Some (Modtype (lookup_module_type im.im_name)) 448 with Not_found -> None 449 in 450 match mmt_opt with 451 None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, 452 (* we don't want to output warning messages for 453 "sig ... end" or "struct ... end" modules not found *) 454 (if im.im_name = Odoc_messages.struct_end || 455 im.im_name = Odoc_messages.sig_end then 456 acc_names_not_found 457 else 458 (NF_mmt im.im_name) :: acc_names_not_found) 459 ) 460 | Some mmt -> 461 im.im_module <- Some mmt ; 462 (true, acc_incomplete_top_module_names, acc_names_not_found) 463 ) 464 | Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl 465 | Element_class_type ct -> 466 associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct 467 | Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 468 | Element_type_extension te -> 469 associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te 470 | Element_exception ex -> 471 ( 472 match ex.ex_alias with 473 None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 474 | Some ea -> 475 match ea.ea_ex with 476 Some _ -> 477 (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 478 | None -> 479 let ex_opt = 480 try Some (lookup_exception ea.ea_name) 481 with Not_found -> None 482 in 483 match ex_opt with 484 None -> (acc_b_modif, 485 (Name.head m_name) :: acc_incomplete_top_module_names, 486 (NF_ex ea.ea_name) :: acc_names_not_found) 487 | Some e -> 488 ea.ea_ex <- Some e ; 489 (true, acc_incomplete_top_module_names, acc_names_not_found) 490 ) 491 | Element_type _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 492 | Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 493 494and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c = 495 let rec iter_kind (acc_b, acc_inc, acc_names) k = 496 match k with 497 Class_structure (inher_l, _) -> 498 let f (acc_b2, acc_inc2, acc_names2) ic = 499 match ic.ic_class with 500 Some _ -> (acc_b2, acc_inc2, acc_names2) 501 | None -> 502 let cct_opt = 503 try Some (Cl (lookup_class ic.ic_name)) 504 with Not_found -> 505 try Some (Cltype (lookup_class_type ic.ic_name, [])) 506 with Not_found -> None 507 in 508 match cct_opt with 509 None -> (acc_b2, (Name.head c.cl_name) :: acc_inc2, 510 (* we don't want to output warning messages for "object ... end" classes not found *) 511 (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) 512 | Some cct -> 513 ic.ic_class <- Some cct ; 514 (true, acc_inc2, acc_names2) 515 in 516 List.fold_left f (acc_b, acc_inc, acc_names) inher_l 517 518 | Class_apply capp -> 519 ( 520 match capp.capp_class with 521 Some _ -> (acc_b, acc_inc, acc_names) 522 | None -> 523 let cl_opt = 524 try Some (lookup_class capp.capp_name) 525 with Not_found -> None 526 in 527 match cl_opt with 528 None -> (acc_b, (Name.head c.cl_name) :: acc_inc, 529 (* we don't want to output warning messages for "object ... end" classes not found *) 530 (if capp.capp_name = Odoc_messages.object_end then acc_names else (NF_c capp.capp_name) :: acc_names)) 531 | Some c -> 532 capp.capp_class <- Some c ; 533 (true, acc_inc, acc_names) 534 ) 535 536 | Class_constr cco -> 537 ( 538 match cco.cco_class with 539 Some _ -> (acc_b, acc_inc, acc_names) 540 | None -> 541 let cl_opt = 542 try Some (lookup_class cco.cco_name) 543 with Not_found -> None 544 in 545 match cl_opt with 546 None -> 547 ( 548 let clt_opt = 549 try Some (lookup_class_type cco.cco_name) 550 with Not_found -> None 551 in 552 match clt_opt with 553 None -> 554 (acc_b, (Name.head c.cl_name) :: acc_inc, 555 (* we don't want to output warning messages for "object ... end" classes not found *) 556 (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names)) 557 | Some ct -> 558 cco.cco_class <- Some (Cltype (ct, [])) ; 559 (true, acc_inc, acc_names) 560 ) 561 | Some c -> 562 cco.cco_class <- Some (Cl c) ; 563 (true, acc_inc, acc_names) 564 ) 565 | Class_constraint (ckind, ctkind) -> 566 let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in 567 associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2) 568 { clt_name = "" ; clt_info = None ; 569 clt_type = c.cl_type ; (* should be ok *) 570 clt_type_parameters = [] ; 571 clt_virtual = false ; 572 clt_kind = ctkind ; 573 clt_loc = Odoc_types.dummy_loc } 574 in 575 iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind 576 577and associate_in_class_type _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct = 578 let iter_kind (acc_b, acc_inc, acc_names) k = 579 match k with 580 Class_signature (inher_l, _) -> 581 let f (acc_b2, acc_inc2, acc_names2) ic = 582 match ic.ic_class with 583 Some _ -> (acc_b2, acc_inc2, acc_names2) 584 | None -> 585 let cct_opt = 586 try Some (Cltype (lookup_class_type ic.ic_name, [])) 587 with Not_found -> 588 try Some (Cl (lookup_class ic.ic_name)) 589 with Not_found -> None 590 in 591 match cct_opt with 592 None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2, 593 (* we don't want to output warning messages for "object ... end" class types not found *) 594 (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) 595 | Some cct -> 596 ic.ic_class <- Some cct ; 597 (true, acc_inc2, acc_names2) 598 in 599 List.fold_left f (acc_b, acc_inc, acc_names) inher_l 600 601 | Class_type cta -> 602 ( 603 match cta.cta_class with 604 Some _ -> (acc_b, acc_inc, acc_names) 605 | None -> 606 let cct_opt = 607 try Some (Cltype (lookup_class_type cta.cta_name, [])) 608 with Not_found -> 609 try Some (Cl (lookup_class cta.cta_name)) 610 with Not_found -> None 611 in 612 match cct_opt with 613 None -> (acc_b, (Name.head ct.clt_name) :: acc_inc, 614 (* we don't want to output warning messages for "object ... end" class types not found *) 615 (if cta.cta_name = Odoc_messages.object_end then acc_names else (NF_cct cta.cta_name) :: acc_names)) 616 | Some c -> 617 cta.cta_class <- Some c ; 618 (true, acc_inc, acc_names) 619 ) 620 in 621 iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind 622 623and associate_in_type_extension _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te = 624 List.fold_left 625 (fun (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) xt -> 626 match xt.xt_alias with 627 None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 628 | Some xa -> 629 match xa.xa_xt with 630 Some _ -> 631 (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 632 | None -> 633 let xt_opt = 634 try Some (lookup_extension xa.xa_name) 635 with Not_found -> None 636 in 637 match xt_opt with 638 None -> (acc_b_modif, 639 (Name.head xt.xt_name) :: acc_incomplete_top_module_names, 640 (NF_xt xa.xa_name) :: acc_names_not_found) 641 | Some x -> 642 xa.xa_xt <- Some x ; 643 (true, acc_incomplete_top_module_names, acc_names_not_found)) 644 (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) 645 te.te_constructors 646 647 648(*************************************************************) 649(** Association of types to elements referenced in comments .*) 650 651let ao = Odoc_misc.apply_opt 652 653let not_found_of_kind kind name = 654 (match kind with 655 RK_module -> Odoc_messages.cross_module_not_found 656 | RK_module_type -> Odoc_messages.cross_module_type_not_found 657 | RK_class -> Odoc_messages.cross_class_not_found 658 | RK_class_type -> Odoc_messages.cross_class_type_not_found 659 | RK_value -> Odoc_messages.cross_value_not_found 660 | RK_type -> Odoc_messages.cross_type_not_found 661 | RK_extension -> Odoc_messages.cross_extension_not_found 662 | RK_exception -> Odoc_messages.cross_exception_not_found 663 | RK_attribute -> Odoc_messages.cross_attribute_not_found 664 | RK_method -> Odoc_messages.cross_method_not_found 665 | RK_section _ -> Odoc_messages.cross_section_not_found 666 | RK_recfield -> Odoc_messages.cross_recfield_not_found 667 | RK_const -> Odoc_messages.cross_const_not_found 668 ) name 669 670let query module_list name = 671 match get_known_elements name with 672 | [] -> 673 ( 674 try 675 let re = Str.regexp ("^"^(Str.quote name)^"$") in 676 let t = Odoc_search.find_section module_list re in 677 let v2 = (name, Some (RK_section t)) in 678 add_verified v2 ; 679 (name, Some (RK_section t)) 680 with 681 Not_found -> 682 (name, None) 683 ) 684 | ele :: _ -> 685 (* we look for the first element with this name *) 686 let (name, kind) = 687 match ele with 688 Odoc_search.Res_module m -> (m.m_name, RK_module) 689 | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type) 690 | Odoc_search.Res_class c -> (c.cl_name, RK_class) 691 | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) 692 | Odoc_search.Res_value v -> (v.val_name, RK_value) 693 | Odoc_search.Res_type t -> (t.ty_name, RK_type) 694 | Odoc_search.Res_extension x -> (x.xt_name, RK_extension) 695 | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) 696 | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) 697 | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) 698 | Odoc_search.Res_section _-> assert false 699 | Odoc_search.Res_recfield (t, f) -> 700 (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield) 701 | Odoc_search.Res_const (t, f) -> 702 (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const) 703 in 704 add_verified (name, Some kind) ; 705 (name, Some kind) 706 707 708let rec search_within_ancestry 709 (finalize,initial_name,query as param) ?parent_name name = 710 let name = Odoc_name.normalize_name name in 711 let res = query name in 712 match res with 713 | (name, Some k) -> finalize (Some (name,k)) 714 | (_, None) -> 715 match parent_name with 716 | None -> 717 finalize None 718 (* *) 719 | Some p -> 720 let parent_name = 721 match Name.father p with 722 "" -> None 723 | s -> Some s 724 in 725 search_within_ancestry param 726 ?parent_name (Name.concat p initial_name) 727 728let search_within_ancestry finalize query ?parent_name name = 729 search_within_ancestry (finalize, name, query) ?parent_name name 730 731 732let rec assoc_comments_text_elements parent_name module_list t_ele = 733 match t_ele with 734 | Raw _ 735 | CodePre _ 736 | Latex _ 737 | Verbatim _ -> t_ele 738 | Bold t -> Bold (assoc_comments_text parent_name module_list t) 739 | Italic t -> Italic (assoc_comments_text parent_name module_list t) 740 | Center t -> Center (assoc_comments_text parent_name module_list t) 741 | Left t -> Left (assoc_comments_text parent_name module_list t) 742 | Right t -> Right (assoc_comments_text parent_name module_list t) 743 | Emphasize t -> Emphasize (assoc_comments_text parent_name module_list t) 744 | List l -> List (List.map (assoc_comments_text parent_name module_list) l) 745 | Enum l -> Enum (List.map (assoc_comments_text parent_name module_list) l) 746 | Newline -> Newline 747 | Block t -> Block (assoc_comments_text parent_name module_list t) 748 | Superscript t -> Superscript (assoc_comments_text parent_name module_list t) 749 | Subscript t -> Subscript (assoc_comments_text parent_name module_list t) 750 | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text parent_name module_list t)) 751 | Link (s, t) -> Link (s, (assoc_comments_text parent_name module_list t)) 752 | Ref (initial_name, None, text_option) -> 753 let finalize = function 754 | Some (name,k) -> Ref (name, Some k, text_option) 755 | None -> 756 Odoc_global.pwarning 757 (Odoc_messages.cross_element_not_found initial_name); 758 Ref (initial_name, None, text_option) in 759 search_within_ancestry finalize (query module_list) ~parent_name initial_name 760 | Code s -> 761 if not !Odoc_global.show_missed_crossref then 762 t_ele 763 else (* Check if s could be turned into a valid cross-reference *) 764 let name = String.trim s in 765 begin 766 (* First, we ignore code fragments with more than one space-separated 767 words: "word1 word2" *) 768 try (ignore (String.index name ' '); t_ele) 769 with Not_found -> 770 if name = "" then t_ele 771 else 772 let first_char = name.[0] in 773 (* Then, we only consider code fragments which start with a 774 distinctly uppercase letter *) 775 if Char.uppercase_ascii first_char <> first_char || 776 Char.lowercase_ascii first_char = first_char then 777 t_ele 778 else 779 (* Some path analysis auxiliary functions *) 780 let path s = 781 String.split_on_char '.' s 782 in 783 let filter = 784 List.filter 785 (fun s -> s <> "" && s.[0] = Char.uppercase_ascii s.[0]) in 786 let rec is_prefix prefix full = 787 match prefix, full with 788 | [], _ -> true 789 | a :: pre, b :: f when a = b -> is_prefix pre f 790 | _ -> false in 791 let p = filter @@ path name and parent_p = path parent_name in 792 let is_path_suffix () = 793 is_prefix (List.rev @@ p) (List.rev @@ parent_p ) in 794 (* heuristic: 795 - if name = parent_name: we are using the name of an element 796 or module in its definition, no need of cross_reference 797 - if the path of name is a suffix of the parent path, we 798 are in the same module, maybe the same function. To decreace 799 the false positive rate, we stop here *) 800 if name = parent_name || is_path_suffix () then 801 t_ele 802 else 803 let finalize = function 804 | None -> t_ele 805 | Some _ -> 806 Odoc_global.pwarning @@ 807 Odoc_messages.code_could_be_cross_reference name parent_name; 808 t_ele in 809 search_within_ancestry finalize (query module_list) ~parent_name 810 name 811 end 812 | Ref (initial_name, Some kind, text_option) -> 813 ( 814 let rec iter_parent ?parent_name name = 815 let v = (name, Some kind) in 816 if was_verified v then 817 Ref (name, Some kind, text_option) 818 else 819 let res = 820 match kind with 821 | RK_section _ -> 822 ( 823 (* we just verify that we find an element of this kind with this name *) 824 try 825 let re = Str.regexp ("^"^(Str.quote name)^"$") in 826 let t = Odoc_search.find_section module_list re in 827 let v2 = (name, Some (RK_section t)) in 828 add_verified v2 ; 829 (name, Some (RK_section t)) 830 with 831 Not_found -> 832 (name, None) 833 ) 834 | _ -> 835 let f = 836 match kind with 837 RK_module -> module_exists 838 | RK_module_type -> module_type_exists 839 | RK_class -> class_exists 840 | RK_class_type -> class_type_exists 841 | RK_value -> value_exists 842 | RK_type -> type_exists 843 | RK_extension -> extension_exists 844 | RK_exception -> exception_exists 845 | RK_attribute -> attribute_exists 846 | RK_method -> method_exists 847 | RK_section _ -> assert false 848 | RK_recfield -> recfield_exists 849 | RK_const -> const_exists 850 in 851 if f name then 852 ( 853 add_verified v ; 854 (name, Some kind) 855 ) 856 else 857 (name, None) 858 in 859 match res with 860 | (name, Some k) -> Ref (name, Some k, text_option) 861 | (_, None) -> 862 match parent_name with 863 None -> 864 Odoc_global.pwarning (not_found_of_kind kind initial_name); 865 Ref (initial_name, None, text_option) 866 | Some p -> 867 let parent_name = 868 match Name.father p with 869 "" -> None 870 | s -> Some s 871 in 872 iter_parent ?parent_name (Name.concat p initial_name) 873 in 874 iter_parent ~parent_name initial_name 875 ) 876 | Module_list l -> 877 Module_list l 878 | Index_list -> 879 Index_list 880 | Custom (s,t) -> Custom (s, (assoc_comments_text parent_name module_list t)) 881 | Target (target, code) -> Target (target, code) 882 883and assoc_comments_text parent_name module_list text = 884 List.map (assoc_comments_text_elements parent_name module_list) text 885 886and assoc_comments_info parent_name module_list i = 887 let ft = assoc_comments_text parent_name module_list in 888 { 889 i with 890 i_desc = ao ft i.i_desc ; 891 i_sees = List.map (fun (sr, t) -> (sr, ft t)) i.i_sees; 892 i_deprecated = ao ft i.i_deprecated ; 893 i_params = List.map (fun (name, t) -> (name, ft t)) i.i_params; 894 i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions; 895 i_return_value = ao ft i.i_return_value ; 896 i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ; 897 } 898 899 900let rec assoc_comments_module_element parent_name module_list m_ele = 901 match m_ele with 902 Element_module m -> 903 Element_module (assoc_comments_module module_list m) 904 | Element_module_type mt -> 905 Element_module_type (assoc_comments_module_type module_list mt) 906 | Element_included_module _ -> 907 m_ele (* don't go down into the aliases *) 908 | Element_class c -> 909 Element_class (assoc_comments_class module_list c) 910 | Element_class_type ct -> 911 Element_class_type (assoc_comments_class_type module_list ct) 912 | Element_value v -> 913 Element_value (assoc_comments_value module_list v) 914 | Element_type_extension te -> 915 Element_type_extension (assoc_comments_type_extension parent_name module_list te) 916 | Element_exception e -> 917 Element_exception (assoc_comments_exception module_list e) 918 | Element_type t -> 919 Element_type (assoc_comments_type module_list t) 920 | Element_module_comment t -> 921 Element_module_comment (assoc_comments_text parent_name module_list t) 922 923and assoc_comments_class_element parent_name module_list c_ele = 924 match c_ele with 925 Class_attribute a -> 926 Class_attribute (assoc_comments_attribute module_list a) 927 | Class_method m -> 928 Class_method (assoc_comments_method module_list m) 929 | Class_comment t -> 930 Class_comment (assoc_comments_text parent_name module_list t) 931 932and assoc_comments_module_kind parent_name module_list mk = 933 match mk with 934 | Module_struct eles -> 935 Module_struct 936 (List.map (assoc_comments_module_element parent_name module_list) eles) 937 | Module_alias _ 938 | Module_functor _ -> 939 mk 940 | Module_apply (mk1, mk2) -> 941 Module_apply (assoc_comments_module_kind parent_name module_list mk1, 942 assoc_comments_module_kind parent_name module_list mk2) 943 | Module_with (mtk, s) -> 944 Module_with (assoc_comments_module_type_kind parent_name module_list mtk, s) 945 | Module_constraint (mk1, mtk) -> 946 Module_constraint 947 (assoc_comments_module_kind parent_name module_list mk1, 948 assoc_comments_module_type_kind parent_name module_list mtk) 949 | Module_typeof _ -> mk 950 | Module_unpack _ -> mk 951 952and assoc_comments_module_type_kind parent_name module_list mtk = 953 match mtk with 954 | Module_type_struct eles -> 955 Module_type_struct 956 (List.map (assoc_comments_module_element parent_name module_list) eles) 957 | Module_type_functor (params, mtk1) -> 958 Module_type_functor 959 (params, assoc_comments_module_type_kind parent_name module_list mtk1) 960 | Module_type_alias _ -> 961 mtk 962 | Module_type_with (mtk1, s) -> 963 Module_type_with 964 (assoc_comments_module_type_kind parent_name module_list mtk1, s) 965 | Module_type_typeof _ -> mtk 966 967and assoc_comments_class_kind parent_name module_list ck = 968 match ck with 969 Class_structure (inher, eles) -> 970 let inher2 = 971 List.map 972 (fun ic -> 973 { ic with 974 ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) 975 inher 976 in 977 Class_structure 978 (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) 979 980 | Class_apply _ 981 | Class_constr _ -> ck 982 | Class_constraint (ck1, ctk) -> 983 Class_constraint (assoc_comments_class_kind parent_name module_list ck1, 984 assoc_comments_class_type_kind parent_name module_list ctk) 985 986and assoc_comments_class_type_kind parent_name module_list ctk = 987 match ctk with 988 Class_signature (inher, eles) -> 989 let inher2 = 990 List.map 991 (fun ic -> { ic with 992 ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) 993 inher 994 in 995 Class_signature (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) 996 997 | Class_type _ -> ctk 998 999 1000and assoc_comments_module module_list m = 1001 m.m_info <- ao (assoc_comments_info m.m_name module_list) m.m_info ; 1002 m.m_kind <- assoc_comments_module_kind m.m_name module_list m.m_kind ; 1003 m 1004 1005and assoc_comments_module_type module_list mt = 1006 mt.mt_info <- ao (assoc_comments_info mt.mt_name module_list) mt.mt_info ; 1007 mt.mt_kind <- ao (assoc_comments_module_type_kind mt.mt_name module_list) mt.mt_kind ; 1008 mt 1009 1010and assoc_comments_class module_list c = 1011 c.cl_info <- ao (assoc_comments_info c.cl_name module_list) c.cl_info ; 1012 c.cl_kind <- assoc_comments_class_kind c.cl_name module_list c.cl_kind ; 1013 assoc_comments_parameter_list c.cl_name module_list c.cl_parameters; 1014 c 1015 1016and assoc_comments_class_type module_list ct = 1017 ct.clt_info <- ao (assoc_comments_info ct.clt_name module_list) ct.clt_info ; 1018 ct.clt_kind <- assoc_comments_class_type_kind ct.clt_name module_list ct.clt_kind ; 1019 ct 1020 1021and assoc_comments_parameter parent_name module_list p = 1022 match p with 1023 Simple_name sn -> 1024 sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text 1025 | Tuple (l, _) -> 1026 List.iter (assoc_comments_parameter parent_name module_list) l 1027 1028and assoc_comments_parameter_list parent_name module_list pl = 1029 List.iter (assoc_comments_parameter parent_name module_list) pl 1030 1031and assoc_comments_value module_list v = 1032 let parent = Name.father v.val_name in 1033 v.val_info <- ao (assoc_comments_info parent module_list) v.val_info ; 1034 assoc_comments_parameter_list parent module_list v.val_parameters; 1035 v 1036 1037and assoc_comments_extension_constructor module_list x = 1038 let parent = Name.father x.xt_name in 1039 x.xt_text <- ao (assoc_comments_info parent module_list) x.xt_text 1040 1041and assoc_comments_type_extension parent_name module_list te = 1042 te.te_info <- ao (assoc_comments_info parent_name module_list) te.te_info; 1043 List.iter (assoc_comments_extension_constructor module_list) te.te_constructors; 1044 te 1045 1046and assoc_comments_exception module_list e = 1047 let parent = Name.father e.ex_name in 1048 e.ex_info <- ao (assoc_comments_info parent module_list) e.ex_info ; 1049 e 1050 1051and assoc_comments_type module_list t = 1052 let parent = Name.father t.ty_name in 1053 t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ; 1054 (match t.ty_kind with 1055 Type_abstract -> () 1056 | Type_variant vl -> 1057 List.iter 1058 (fun vc -> vc.vc_text <- ao (assoc_comments_info parent module_list) vc.vc_text) 1059 vl 1060 | Type_record fl -> 1061 List.iter 1062 (fun rf -> rf.rf_text <- ao (assoc_comments_info parent module_list) rf.rf_text) 1063 fl 1064 | Type_open -> () 1065 ); 1066 t 1067 1068and assoc_comments_attribute module_list a = 1069 let _ = assoc_comments_value module_list a.att_value in 1070 a 1071 1072and assoc_comments_method module_list m = 1073 let parent_name = Name.father m.met_value.val_name in 1074 let _ = assoc_comments_value module_list m.met_value in 1075 assoc_comments_parameter_list parent_name module_list m.met_value.val_parameters; 1076 m 1077 1078 1079let associate_type_of_elements_in_comments module_list = 1080 List.map (assoc_comments_module module_list) module_list 1081 1082 1083(***********************************************************) 1084(** The function which performs all the cross referencing. *) 1085let associate module_list = 1086 get_alias_names module_list ; 1087 init_known_elements_map module_list; 1088 let rec remove_doubles acc = function 1089 [] -> acc 1090 | h :: q -> 1091 if List.mem h acc then remove_doubles acc q 1092 else remove_doubles (h :: acc) q 1093 in 1094 let rec iter incomplete_modules = 1095 let (b_modif, remaining_inc_modules, acc_names_not_found) = 1096 List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules 1097 in 1098 let remaining_no_doubles = remove_doubles [] remaining_inc_modules in 1099 let remaining_modules = List.filter 1100 (fun m -> List.mem m.m_name remaining_no_doubles) 1101 incomplete_modules 1102 in 1103 if b_modif then 1104 (* we may be able to associate something else *) 1105 iter remaining_modules 1106 else 1107 (* nothing changed, we won't be able to associate any more *) 1108 acc_names_not_found 1109 in 1110 let names_not_found = iter module_list in 1111 ( 1112 match names_not_found with 1113 [] -> 1114 () 1115 | l -> 1116 List.iter 1117 (fun nf -> 1118 Odoc_global.pwarning 1119 ( 1120 match nf with 1121 | NF_mt n -> Odoc_messages.cross_module_type_not_found n 1122 | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n 1123 | NF_c n -> Odoc_messages.cross_class_not_found n 1124 | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n 1125 | NF_xt n -> Odoc_messages.cross_extension_not_found n 1126 | NF_ex n -> Odoc_messages.cross_exception_not_found n 1127 ); 1128 ) 1129 l 1130 ) ; 1131 1132 (* Find a type for each name of element which is referenced in comments. *) 1133 ignore (associate_type_of_elements_in_comments module_list) 1134