ocaml/ocamldoc/odoc_cross.ml

1132 lines
44 KiB
OCaml

(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Cross referencing. *)
open Odoc_module
open Odoc_class
open Odoc_extension
open Odoc_exception
open Odoc_types
open Odoc_value
open Odoc_type
open Odoc_parameter
(*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3,
in order to associate the element with complete information. *)
(** The module used to keep what refs were modified. *)
module S = Set.Make
(
struct type t = string * ref_kind option
let compare = Stdlib.compare
end
)
let verified_refs = ref S.empty
let add_verified v = verified_refs := S.add v !verified_refs
let was_verified v = S.mem v !verified_refs
(** The module with the predicates used to get the aliased modules, classes and exceptions. *)
module P_alias =
struct
type t = int
let p_module m _ =
(true,
match m.m_kind with
Module_alias _ -> true
| _ -> false
)
let p_module_type mt _ =
(true,
match mt.mt_kind with
Some (Module_type_alias _) -> true
| _ -> false
)
let p_class _ _ = (false, false)
let p_class_type _ _ = (false, false)
let p_value _ _ = false
let p_recfield _ _ _ = false
let p_const _ _ _ = false
let p_type _ _ = (false, false)
let p_extension x _ = x.xt_alias <> None
let p_exception e _ = e.ex_alias <> None
let p_attribute _ _ = false
let p_method _ _ = false
let p_section _ _ = false
end
(** The module used to get the aliased elements. *)
module Search_alias = Odoc_search.Search (P_alias)
type alias_state =
| Alias_to_resolve
(** Couples of module name aliases. *)
let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create 13 ;;
(** Couples of module or module type name aliases. *)
let module_and_modtype_aliases = Hashtbl.create 13;;
(** Couples of extension name aliases. *)
let extension_aliases = Hashtbl.create 13;;
(** Couples of exception name aliases. *)
let exception_aliases = Hashtbl.create 13;;
let rec build_alias_list = function
[] -> ()
| (Odoc_search.Res_module m) :: q ->
(
match m.m_kind with
Module_alias ma ->
Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve);
Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve)
| _ -> ()
);
build_alias_list q
| (Odoc_search.Res_module_type mt) :: q ->
(
match mt.mt_kind with
Some (Module_type_alias mta) ->
Hashtbl.add module_and_modtype_aliases
mt.mt_name (mta.mta_name, Alias_to_resolve)
| _ -> ()
);
build_alias_list q
| (Odoc_search.Res_extension x) :: q ->
(
match x.xt_alias with
None -> ()
| Some xa ->
Hashtbl.add extension_aliases
x.xt_name (xa.xa_name,Alias_to_resolve)
);
build_alias_list q
| (Odoc_search.Res_exception e) :: q ->
(
match e.ex_alias with
None -> ()
| Some ea ->
Hashtbl.add exception_aliases
e.ex_name (ea.ea_name,Alias_to_resolve)
);
build_alias_list q
| _ :: q ->
build_alias_list q
(** Retrieve the aliases for modules, module types and exceptions
and put them in global hash tables. *)
let get_alias_names module_list =
Hashtbl.clear module_aliases;
Hashtbl.clear module_and_modtype_aliases;
Hashtbl.clear extension_aliases;
Hashtbl.clear exception_aliases;
build_alias_list (Search_alias.search module_list 0)
module Ele_map = Misc.Stdlib.String.Map
let known_elements = ref Ele_map.empty
let add_known_element name k =
try
let l = Ele_map.find name !known_elements in
let s = Ele_map.remove name !known_elements in
known_elements := Ele_map.add name (k::l) s
with
Not_found ->
known_elements := Ele_map.add name [k] !known_elements
let get_known_elements name =
try Ele_map.find name !known_elements
with Not_found -> []
let kind_name_exists kind =
let pred =
match kind with
RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false)
| RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false)
| RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false)
| RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false)
| RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false)
| RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false)
| RK_extension -> (fun e -> match e with Odoc_search.Res_extension _ -> true | _ -> false)
| RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false)
| RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false)
| RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false)
| RK_section _ -> assert false
| RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false)
| RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false)
in
fun name ->
try List.exists pred (get_known_elements name)
with Not_found -> false
let module_exists = kind_name_exists RK_module
let module_type_exists = kind_name_exists RK_module_type
let class_exists = kind_name_exists RK_class
let class_type_exists = kind_name_exists RK_class_type
let value_exists = kind_name_exists RK_value
let type_exists = kind_name_exists RK_type
let extension_exists = kind_name_exists RK_extension
let exception_exists = kind_name_exists RK_exception
let attribute_exists = kind_name_exists RK_attribute
let method_exists = kind_name_exists RK_method
let recfield_exists = kind_name_exists RK_recfield
let const_exists = kind_name_exists RK_const
let lookup_module name =
match List.find
(fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_module m -> m
| _ -> assert false
let lookup_module_type name =
match List.find
(fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_module_type m -> m
| _ -> assert false
let lookup_class name =
match List.find
(fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_class c -> c
| _ -> assert false
let lookup_class_type name =
match List.find
(fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_class_type c -> c
| _ -> assert false
let lookup_extension name =
match List.find
(fun k -> match k with Odoc_search.Res_extension _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_extension x -> x
| _ -> assert false
let lookup_exception name =
match List.find
(fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false)
(get_known_elements name)
with
| Odoc_search.Res_exception e -> e
| _ -> assert false
class scan =
object
inherit Odoc_scan.scanner
method! scan_value v =
add_known_element v.val_name (Odoc_search.Res_value v)
method! scan_type_recfield t f =
add_known_element
(Printf.sprintf "%s.%s" t.ty_name f.rf_name)
(Odoc_search.Res_recfield (t, f))
method! scan_type_const t f =
add_known_element
(Printf.sprintf "%s.%s" t.ty_name f.vc_name)
(Odoc_search.Res_const (t, f))
method! scan_type_pre t =
add_known_element t.ty_name (Odoc_search.Res_type t);
true
method! scan_extension_constructor x =
add_known_element x.xt_name (Odoc_search.Res_extension x)
method! scan_exception e =
add_known_element e.ex_name (Odoc_search.Res_exception e)
method! scan_attribute a =
add_known_element a.att_value.val_name
(Odoc_search.Res_attribute a)
method! scan_method m =
add_known_element m.met_value.val_name
(Odoc_search.Res_method m)
method! scan_class_pre c =
add_known_element c.cl_name (Odoc_search.Res_class c);
true
method! scan_class_type_pre c =
add_known_element c.clt_name (Odoc_search.Res_class_type c);
true
method! scan_module_pre m =
add_known_element m.m_name (Odoc_search.Res_module m);
true
method! scan_module_type_pre m =
add_known_element m.mt_name (Odoc_search.Res_module_type m);
true
end
let init_known_elements_map module_list =
let c = new scan in
c#scan_module_list module_list
(** The type to describe the names not found. *)
type not_found_name =
| NF_mt of Name.t
| NF_mmt of Name.t
| NF_c of Name.t
| NF_cct of Name.t
| NF_xt of Name.t
| NF_ex of Name.t
(** Functions to find and associate aliases elements. *)
let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m =
let rec iter_kind (acc_b, acc_inc, acc_names) k =
match k with
Module_struct elements ->
List.fold_left
(associate_in_module_element module_list m.m_name)
(acc_b, acc_inc, acc_names)
elements
| Module_alias ma ->
(
match ma.ma_module with
Some _ ->
(acc_b, acc_inc, acc_names)
| None ->
let mmt_opt =
try Some (Mod (lookup_module ma.ma_name))
with Not_found ->
try Some (Modtype (lookup_module_type ma.ma_name))
with Not_found -> None
in
match mmt_opt with
None -> (acc_b, (Name.head m.m_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
(if ma.ma_name = Odoc_messages.struct_end ||
ma.ma_name = Odoc_messages.sig_end then
acc_names
else
(NF_mmt ma.ma_name) :: acc_names)
)
| Some mmt ->
ma.ma_module <- Some mmt ;
(true, acc_inc, acc_names)
)
| Module_functor (_, k) ->
iter_kind (acc_b, acc_inc, acc_names) k
| Module_with (tk, _) ->
associate_in_module_type module_list (acc_b, acc_inc, acc_names)
{ mt_name = "" ; mt_info = None ; mt_type = None ;
mt_is_interface = false ; mt_file = ""; mt_kind = Some tk ;
mt_loc = Odoc_types.dummy_loc }
| Module_apply (k1, k2) ->
let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k1 in
iter_kind (acc_b2, acc_inc2, acc_names2) k2
| Module_constraint (k, tk) ->
let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k in
associate_in_module_type module_list (acc_b2, acc_inc2, acc_names2)
{ mt_name = "" ; mt_info = None ; mt_type = None ;
mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
mt_loc = Odoc_types.dummy_loc }
| Module_typeof _ ->
(acc_b, acc_inc, acc_names)
| Module_unpack (_code, mta) ->
begin
match mta.mta_module with
Some _ ->
(acc_b, acc_inc, acc_names)
| None ->
let mt_opt =
try Some (lookup_module_type mta.mta_name)
with Not_found -> None
in
match mt_opt with
None -> (acc_b, (Name.head m.m_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
(if mta.mta_name = Odoc_messages.struct_end ||
mta.mta_name = Odoc_messages.sig_end then
acc_names
else
(NF_mt mta.mta_name) :: acc_names)
)
| Some mt ->
mta.mta_module <- Some mt ;
(true, acc_inc, acc_names)
end
in
iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m.m_kind
and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt =
let rec iter_kind (acc_b, acc_inc, acc_names) k =
match k with
Module_type_struct elements ->
List.fold_left
(associate_in_module_element module_list mt.mt_name)
(acc_b, acc_inc, acc_names)
elements
| Module_type_functor (_, k) ->
iter_kind (acc_b, acc_inc, acc_names) k
| Module_type_with (k, _) ->
iter_kind (acc_b, acc_inc, acc_names) k
| Module_type_alias mta ->
begin
match mta.mta_module with
Some _ ->
(acc_b, acc_inc, acc_names)
| None ->
let mta_name =
Name.get_relative_opt
!Odoc_global.library_namespace
mta.mta_name in
let mt_opt =
try Some (lookup_module_type mta_name)
with Not_found -> None
in
match mt_opt with
None -> (acc_b, (Name.head mt.mt_name) :: acc_inc,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
(if mta.mta_name = Odoc_messages.struct_end ||
mta.mta_name = Odoc_messages.sig_end then
acc_names
else
(NF_mt mta_name) :: acc_names)
)
| Some mt ->
mta.mta_module <- Some mt ;
(true, acc_inc, acc_names)
end
| Module_type_typeof _ ->
(acc_b, acc_inc, acc_names)
in
match mt.mt_kind with
None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k
and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element =
match element with
Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m
| Element_module_type mt ->
associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt
| Element_included_module im ->
(
match im.im_module with
Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| None ->
let mmt_opt =
try Some (Mod (lookup_module im.im_name))
with Not_found ->
try Some (Modtype (lookup_module_type im.im_name))
with Not_found -> None
in
match mmt_opt with
None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names,
(* we don't want to output warning messages for
"sig ... end" or "struct ... end" modules not found *)
(if im.im_name = Odoc_messages.struct_end ||
im.im_name = Odoc_messages.sig_end then
acc_names_not_found
else
(NF_mmt im.im_name) :: acc_names_not_found)
)
| Some mmt ->
im.im_module <- Some mmt ;
(true, acc_incomplete_top_module_names, acc_names_not_found)
)
| Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl
| Element_class_type ct ->
associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct
| Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Element_type_extension te ->
associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te
| Element_exception ex ->
(
match ex.ex_alias with
None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Some ea ->
match ea.ea_ex with
Some _ ->
(acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| None ->
let ex_opt =
try Some (lookup_exception ea.ea_name)
with Not_found -> None
in
match ex_opt with
None -> (acc_b_modif,
(Name.head m_name) :: acc_incomplete_top_module_names,
(NF_ex ea.ea_name) :: acc_names_not_found)
| Some e ->
ea.ea_ex <- Some e ;
(true, acc_incomplete_top_module_names, acc_names_not_found)
)
| Element_type _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c =
let rec iter_kind (acc_b, acc_inc, acc_names) k =
match k with
Class_structure (inher_l, _) ->
let f (acc_b2, acc_inc2, acc_names2) ic =
match ic.ic_class with
Some _ -> (acc_b2, acc_inc2, acc_names2)
| None ->
let cct_opt =
try Some (Cl (lookup_class ic.ic_name))
with Not_found ->
try Some (Cltype (lookup_class_type ic.ic_name, []))
with Not_found -> None
in
match cct_opt with
None -> (acc_b2, (Name.head c.cl_name) :: acc_inc2,
(* we don't want to output warning messages for "object ... end" classes not found *)
(if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2))
| Some cct ->
ic.ic_class <- Some cct ;
(true, acc_inc2, acc_names2)
in
List.fold_left f (acc_b, acc_inc, acc_names) inher_l
| Class_apply capp ->
(
match capp.capp_class with
Some _ -> (acc_b, acc_inc, acc_names)
| None ->
let cl_opt =
try Some (lookup_class capp.capp_name)
with Not_found -> None
in
match cl_opt with
None -> (acc_b, (Name.head c.cl_name) :: acc_inc,
(* we don't want to output warning messages for "object ... end" classes not found *)
(if capp.capp_name = Odoc_messages.object_end then acc_names else (NF_c capp.capp_name) :: acc_names))
| Some c ->
capp.capp_class <- Some c ;
(true, acc_inc, acc_names)
)
| Class_constr cco ->
(
match cco.cco_class with
Some _ -> (acc_b, acc_inc, acc_names)
| None ->
let cl_opt =
try Some (lookup_class cco.cco_name)
with Not_found -> None
in
match cl_opt with
None ->
(
let clt_opt =
try Some (lookup_class_type cco.cco_name)
with Not_found -> None
in
match clt_opt with
None ->
(acc_b, (Name.head c.cl_name) :: acc_inc,
(* we don't want to output warning messages for "object ... end" classes not found *)
(if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names))
| Some ct ->
cco.cco_class <- Some (Cltype (ct, [])) ;
(true, acc_inc, acc_names)
)
| Some c ->
cco.cco_class <- Some (Cl c) ;
(true, acc_inc, acc_names)
)
| Class_constraint (ckind, ctkind) ->
let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in
associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2)
{ clt_name = "" ; clt_info = None ;
clt_type = c.cl_type ; (* should be ok *)
clt_type_parameters = [] ;
clt_virtual = false ;
clt_kind = ctkind ;
clt_loc = Odoc_types.dummy_loc }
in
iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind
and associate_in_class_type _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
let iter_kind (acc_b, acc_inc, acc_names) k =
match k with
Class_signature (inher_l, _) ->
let f (acc_b2, acc_inc2, acc_names2) ic =
match ic.ic_class with
Some _ -> (acc_b2, acc_inc2, acc_names2)
| None ->
let cct_opt =
try Some (Cltype (lookup_class_type ic.ic_name, []))
with Not_found ->
try Some (Cl (lookup_class ic.ic_name))
with Not_found -> None
in
match cct_opt with
None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2,
(* we don't want to output warning messages for "object ... end" class types not found *)
(if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2))
| Some cct ->
ic.ic_class <- Some cct ;
(true, acc_inc2, acc_names2)
in
List.fold_left f (acc_b, acc_inc, acc_names) inher_l
| Class_type cta ->
(
match cta.cta_class with
Some _ -> (acc_b, acc_inc, acc_names)
| None ->
let cct_opt =
try Some (Cltype (lookup_class_type cta.cta_name, []))
with Not_found ->
try Some (Cl (lookup_class cta.cta_name))
with Not_found -> None
in
match cct_opt with
None -> (acc_b, (Name.head ct.clt_name) :: acc_inc,
(* we don't want to output warning messages for "object ... end" class types not found *)
(if cta.cta_name = Odoc_messages.object_end then acc_names else (NF_cct cta.cta_name) :: acc_names))
| Some c ->
cta.cta_class <- Some c ;
(true, acc_inc, acc_names)
)
in
iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind
and associate_in_type_extension _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te =
List.fold_left
(fun (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) xt ->
match xt.xt_alias with
None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| Some xa ->
match xa.xa_xt with
Some _ ->
(acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
| None ->
let xt_opt =
try Some (lookup_extension xa.xa_name)
with Not_found -> None
in
match xt_opt with
None -> (acc_b_modif,
(Name.head xt.xt_name) :: acc_incomplete_top_module_names,
(NF_xt xa.xa_name) :: acc_names_not_found)
| Some x ->
xa.xa_xt <- Some x ;
(true, acc_incomplete_top_module_names, acc_names_not_found))
(acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)
te.te_constructors
(*************************************************************)
(** Association of types to elements referenced in comments .*)
let ao = Odoc_misc.apply_opt
let not_found_of_kind kind name =
(match kind with
RK_module -> Odoc_messages.cross_module_not_found
| RK_module_type -> Odoc_messages.cross_module_type_not_found
| RK_class -> Odoc_messages.cross_class_not_found
| RK_class_type -> Odoc_messages.cross_class_type_not_found
| RK_value -> Odoc_messages.cross_value_not_found
| RK_type -> Odoc_messages.cross_type_not_found
| RK_extension -> Odoc_messages.cross_extension_not_found
| RK_exception -> Odoc_messages.cross_exception_not_found
| RK_attribute -> Odoc_messages.cross_attribute_not_found
| RK_method -> Odoc_messages.cross_method_not_found
| RK_section _ -> Odoc_messages.cross_section_not_found
| RK_recfield -> Odoc_messages.cross_recfield_not_found
| RK_const -> Odoc_messages.cross_const_not_found
) name
let query module_list name =
match get_known_elements name with
| [] ->
(
try
let re = Str.regexp ("^"^(Str.quote name)^"$") in
let t = Odoc_search.find_section module_list re in
let v2 = (name, Some (RK_section t)) in
add_verified v2 ;
(name, Some (RK_section t))
with
Not_found ->
(name, None)
)
| ele :: _ ->
(* we look for the first element with this name *)
let (name, kind) =
match ele with
Odoc_search.Res_module m -> (m.m_name, RK_module)
| Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type)
| Odoc_search.Res_class c -> (c.cl_name, RK_class)
| Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type)
| Odoc_search.Res_value v -> (v.val_name, RK_value)
| Odoc_search.Res_type t -> (t.ty_name, RK_type)
| Odoc_search.Res_extension x -> (x.xt_name, RK_extension)
| Odoc_search.Res_exception e -> (e.ex_name, RK_exception)
| Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute)
| Odoc_search.Res_method m -> (m.met_value.val_name, RK_method)
| Odoc_search.Res_section _-> assert false
| Odoc_search.Res_recfield (t, f) ->
(Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield)
| Odoc_search.Res_const (t, f) ->
(Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const)
in
add_verified (name, Some kind) ;
(name, Some kind)
let rec search_within_ancestry
(finalize,initial_name,query as param) ?parent_name name =
let name = Odoc_name.normalize_name name in
let res = query name in
match res with
| (name, Some k) -> finalize (Some (name,k))
| (_, None) ->
match parent_name with
| None ->
finalize None
(* *)
| Some p ->
let parent_name =
match Name.father p with
"" -> None
| s -> Some s
in
search_within_ancestry param
?parent_name (Name.concat p initial_name)
let search_within_ancestry finalize query ?parent_name name =
search_within_ancestry (finalize, name, query) ?parent_name name
let rec assoc_comments_text_elements parent_name module_list t_ele =
match t_ele with
| Raw _
| CodePre _
| Latex _
| Verbatim _ -> t_ele
| Bold t -> Bold (assoc_comments_text parent_name module_list t)
| Italic t -> Italic (assoc_comments_text parent_name module_list t)
| Center t -> Center (assoc_comments_text parent_name module_list t)
| Left t -> Left (assoc_comments_text parent_name module_list t)
| Right t -> Right (assoc_comments_text parent_name module_list t)
| Emphasize t -> Emphasize (assoc_comments_text parent_name module_list t)
| List l -> List (List.map (assoc_comments_text parent_name module_list) l)
| Enum l -> Enum (List.map (assoc_comments_text parent_name module_list) l)
| Newline -> Newline
| Block t -> Block (assoc_comments_text parent_name module_list t)
| Superscript t -> Superscript (assoc_comments_text parent_name module_list t)
| Subscript t -> Subscript (assoc_comments_text parent_name module_list t)
| Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text parent_name module_list t))
| Link (s, t) -> Link (s, (assoc_comments_text parent_name module_list t))
| Ref (initial_name, None, text_option) ->
let finalize = function
| Some (name,k) -> Ref (name, Some k, text_option)
| None ->
Odoc_global.pwarning
(Odoc_messages.cross_element_not_found initial_name);
Ref (initial_name, None, text_option) in
search_within_ancestry finalize (query module_list) ~parent_name initial_name
| Code s ->
if not !Odoc_global.show_missed_crossref then
t_ele
else (* Check if s could be turned into a valid cross-reference *)
let name = String.trim s in
begin
(* First, we ignore code fragments with more than one space-separated
words: "word1 word2" *)
try (ignore (String.index name ' '); t_ele)
with Not_found ->
if name = "" then t_ele
else
let first_char = name.[0] in
(* Then, we only consider code fragments which start with a
distinctly uppercase letter *)
if Char.uppercase_ascii first_char <> first_char ||
Char.lowercase_ascii first_char = first_char then
t_ele
else
(* Some path analysis auxiliary functions *)
let path s =
String.split_on_char '.' s
in
let filter =
List.filter
(fun s -> s <> "" && s.[0] = Char.uppercase_ascii s.[0]) in
let rec is_prefix prefix full =
match prefix, full with
| [], _ -> true
| a :: pre, b :: f when a = b -> is_prefix pre f
| _ -> false in
let p = filter @@ path name and parent_p = path parent_name in
let is_path_suffix () =
is_prefix (List.rev @@ p) (List.rev @@ parent_p ) in
(* heuristic:
- if name = parent_name: we are using the name of an element
or module in its definition, no need of cross_reference
- if the path of name is a suffix of the parent path, we
are in the same module, maybe the same function. To decrease
the false positive rate, we stop here *)
if name = parent_name || is_path_suffix () then
t_ele
else
let finalize = function
| None -> t_ele
| Some _ ->
Odoc_global.pwarning @@
Odoc_messages.code_could_be_cross_reference name parent_name;
t_ele in
search_within_ancestry finalize (query module_list) ~parent_name
name
end
| Ref (initial_name, Some kind, text_option) ->
(
let rec iter_parent ?parent_name name =
let v = (name, Some kind) in
if was_verified v then
Ref (name, Some kind, text_option)
else
let res =
match kind with
| RK_section _ ->
(
(* we just verify that we find an element of this kind with this name *)
try
let re = Str.regexp ("^"^(Str.quote name)^"$") in
let t = Odoc_search.find_section module_list re in
let v2 = (name, Some (RK_section t)) in
add_verified v2 ;
(name, Some (RK_section t))
with
Not_found ->
(name, None)
)
| _ ->
let f =
match kind with
RK_module -> module_exists
| RK_module_type -> module_type_exists
| RK_class -> class_exists
| RK_class_type -> class_type_exists
| RK_value -> value_exists
| RK_type -> type_exists
| RK_extension -> extension_exists
| RK_exception -> exception_exists
| RK_attribute -> attribute_exists
| RK_method -> method_exists
| RK_section _ -> assert false
| RK_recfield -> recfield_exists
| RK_const -> const_exists
in
if f name then
(
add_verified v ;
(name, Some kind)
)
else
(name, None)
in
match res with
| (name, Some k) -> Ref (name, Some k, text_option)
| (_, None) ->
match parent_name with
None ->
Odoc_global.pwarning (not_found_of_kind kind initial_name);
Ref (initial_name, None, text_option)
| Some p ->
let parent_name =
match Name.father p with
"" -> None
| s -> Some s
in
iter_parent ?parent_name (Name.concat p initial_name)
in
iter_parent ~parent_name initial_name
)
| Module_list l ->
Module_list l
| Index_list ->
Index_list
| Custom (s,t) -> Custom (s, (assoc_comments_text parent_name module_list t))
| Target (target, code) -> Target (target, code)
and assoc_comments_text parent_name module_list text =
List.map (assoc_comments_text_elements parent_name module_list) text
and assoc_comments_info parent_name module_list i =
let ft = assoc_comments_text parent_name module_list in
{
i with
i_desc = ao ft i.i_desc ;
i_sees = List.map (fun (sr, t) -> (sr, ft t)) i.i_sees;
i_deprecated = ao ft i.i_deprecated ;
i_params = List.map (fun (name, t) -> (name, ft t)) i.i_params;
i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions;
i_return_value = ao ft i.i_return_value ;
i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ;
}
let rec assoc_comments_module_element parent_name module_list m_ele =
match m_ele with
Element_module m ->
Element_module (assoc_comments_module module_list m)
| Element_module_type mt ->
Element_module_type (assoc_comments_module_type module_list mt)
| Element_included_module _ ->
m_ele (* don't go down into the aliases *)
| Element_class c ->
Element_class (assoc_comments_class module_list c)
| Element_class_type ct ->
Element_class_type (assoc_comments_class_type module_list ct)
| Element_value v ->
Element_value (assoc_comments_value module_list v)
| Element_type_extension te ->
Element_type_extension (assoc_comments_type_extension parent_name module_list te)
| Element_exception e ->
Element_exception (assoc_comments_exception module_list e)
| Element_type t ->
Element_type (assoc_comments_type module_list t)
| Element_module_comment t ->
Element_module_comment (assoc_comments_text parent_name module_list t)
and assoc_comments_class_element parent_name module_list c_ele =
match c_ele with
Class_attribute a ->
Class_attribute (assoc_comments_attribute module_list a)
| Class_method m ->
Class_method (assoc_comments_method module_list m)
| Class_comment t ->
Class_comment (assoc_comments_text parent_name module_list t)
and assoc_comments_module_kind parent_name module_list mk =
match mk with
| Module_struct eles ->
Module_struct
(List.map (assoc_comments_module_element parent_name module_list) eles)
| Module_alias _
| Module_functor _ ->
mk
| Module_apply (mk1, mk2) ->
Module_apply (assoc_comments_module_kind parent_name module_list mk1,
assoc_comments_module_kind parent_name module_list mk2)
| Module_with (mtk, s) ->
Module_with (assoc_comments_module_type_kind parent_name module_list mtk, s)
| Module_constraint (mk1, mtk) ->
Module_constraint
(assoc_comments_module_kind parent_name module_list mk1,
assoc_comments_module_type_kind parent_name module_list mtk)
| Module_typeof _ -> mk
| Module_unpack _ -> mk
and assoc_comments_module_type_kind parent_name module_list mtk =
match mtk with
| Module_type_struct eles ->
Module_type_struct
(List.map (assoc_comments_module_element parent_name module_list) eles)
| Module_type_functor (params, mtk1) ->
Module_type_functor
(params, assoc_comments_module_type_kind parent_name module_list mtk1)
| Module_type_alias _ ->
mtk
| Module_type_with (mtk1, s) ->
Module_type_with
(assoc_comments_module_type_kind parent_name module_list mtk1, s)
| Module_type_typeof _ -> mtk
and assoc_comments_class_kind parent_name module_list ck =
match ck with
Class_structure (inher, eles) ->
let inher2 =
List.map
(fun ic ->
{ ic with
ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text })
inher
in
Class_structure
(inher2, List.map (assoc_comments_class_element parent_name module_list) eles)
| Class_apply _
| Class_constr _ -> ck
| Class_constraint (ck1, ctk) ->
Class_constraint (assoc_comments_class_kind parent_name module_list ck1,
assoc_comments_class_type_kind parent_name module_list ctk)
and assoc_comments_class_type_kind parent_name module_list ctk =
match ctk with
Class_signature (inher, eles) ->
let inher2 =
List.map
(fun ic -> { ic with
ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text })
inher
in
Class_signature (inher2, List.map (assoc_comments_class_element parent_name module_list) eles)
| Class_type _ -> ctk
and assoc_comments_module module_list m =
m.m_info <- ao (assoc_comments_info m.m_name module_list) m.m_info ;
m.m_kind <- assoc_comments_module_kind m.m_name module_list m.m_kind ;
m
and assoc_comments_module_type module_list mt =
mt.mt_info <- ao (assoc_comments_info mt.mt_name module_list) mt.mt_info ;
mt.mt_kind <- ao (assoc_comments_module_type_kind mt.mt_name module_list) mt.mt_kind ;
mt
and assoc_comments_class module_list c =
c.cl_info <- ao (assoc_comments_info c.cl_name module_list) c.cl_info ;
c.cl_kind <- assoc_comments_class_kind c.cl_name module_list c.cl_kind ;
assoc_comments_parameter_list c.cl_name module_list c.cl_parameters;
c
and assoc_comments_class_type module_list ct =
ct.clt_info <- ao (assoc_comments_info ct.clt_name module_list) ct.clt_info ;
ct.clt_kind <- assoc_comments_class_type_kind ct.clt_name module_list ct.clt_kind ;
ct
and assoc_comments_parameter parent_name module_list p =
match p with
Simple_name sn ->
sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text
| Tuple (l, _) ->
List.iter (assoc_comments_parameter parent_name module_list) l
and assoc_comments_parameter_list parent_name module_list pl =
List.iter (assoc_comments_parameter parent_name module_list) pl
and assoc_comments_value module_list v =
let parent = Name.father v.val_name in
v.val_info <- ao (assoc_comments_info parent module_list) v.val_info ;
assoc_comments_parameter_list parent module_list v.val_parameters;
v
and assoc_comments_extension_constructor module_list x =
let parent = Name.father x.xt_name in
x.xt_text <- ao (assoc_comments_info parent module_list) x.xt_text
and assoc_comments_type_extension parent_name module_list te =
te.te_info <- ao (assoc_comments_info parent_name module_list) te.te_info;
List.iter (assoc_comments_extension_constructor module_list) te.te_constructors;
te
and assoc_comments_exception module_list e =
let parent = Name.father e.ex_name in
e.ex_info <- ao (assoc_comments_info parent module_list) e.ex_info ;
e
and assoc_comments_type module_list t =
let parent = Name.father t.ty_name in
t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ;
(match t.ty_kind with
Type_abstract -> ()
| Type_variant vl ->
List.iter
(fun vc -> vc.vc_text <- ao (assoc_comments_info parent module_list) vc.vc_text)
vl
| Type_record fl ->
List.iter
(fun rf -> rf.rf_text <- ao (assoc_comments_info parent module_list) rf.rf_text)
fl
| Type_open -> ()
);
t
and assoc_comments_attribute module_list a =
let _ = assoc_comments_value module_list a.att_value in
a
and assoc_comments_method module_list m =
let parent_name = Name.father m.met_value.val_name in
let _ = assoc_comments_value module_list m.met_value in
assoc_comments_parameter_list parent_name module_list m.met_value.val_parameters;
m
let associate_type_of_elements_in_comments module_list =
List.map (assoc_comments_module module_list) module_list
(***********************************************************)
(** The function which performs all the cross referencing. *)
let associate module_list =
get_alias_names module_list ;
init_known_elements_map module_list;
let rec remove_doubles acc = function
[] -> acc
| h :: q ->
if List.mem h acc then remove_doubles acc q
else remove_doubles (h :: acc) q
in
let rec iter incomplete_modules =
let (b_modif, remaining_inc_modules, acc_names_not_found) =
List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules
in
let remaining_no_doubles = remove_doubles [] remaining_inc_modules in
let remaining_modules = List.filter
(fun m -> List.mem m.m_name remaining_no_doubles)
incomplete_modules
in
if b_modif then
(* we may be able to associate something else *)
iter remaining_modules
else
(* nothing changed, we won't be able to associate any more *)
acc_names_not_found
in
let names_not_found = iter module_list in
(
match names_not_found with
[] ->
()
| l ->
List.iter
(fun nf ->
Odoc_global.pwarning
(
match nf with
| NF_mt n -> Odoc_messages.cross_module_type_not_found n
| NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n
| NF_c n -> Odoc_messages.cross_class_not_found n
| NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n
| NF_xt n -> Odoc_messages.cross_extension_not_found n
| NF_ex n -> Odoc_messages.cross_exception_not_found n
);
)
l
) ;
(* Find a type for each name of element which is referenced in comments. *)
ignore (associate_type_of_elements_in_comments module_list)