l4/pkg/ocaml/contrib/ocamldoc/odoc_cross.ml

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