let rec iter (f_opt, inc) = function

[] | _ :: [] -> (f_opt, inc)

| "-g" :: file :: q when

| "-i" :: dir :: q ->

| _ :: q ->

in

iter (None, []) arg_list

Dynlink.init ();

Dynlink.allow_unsafe_modules true;

try

with

let _ = print_DEBUG "Fin du chargement dynamique �ventuel"

List.flatten

(List.map

(fun f ->

)

!Odoc_args.load

)

| Some f ->

try Odoc_analyse.dump_modules f modules

with Failure s ->

let _ =

match !Odoc_args.doc_generator with

with

e ->

match e with

Syntaxerr.report_error err;

| Failure s ->

| e ->

(** Analysis of an interface file. Returns (Some signature) if

no error occured, else None and an error message is printed.*)

try

let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf sourcefile in

match parsetree_typedtree_opt with

| Some (parsetree, typedtree) ->

with

| Sys_error s

| Failure s ->

| e ->

)

else

if Filename.check_suffix sourcefile "mli" then

(

try

with

| Sys_error s

| Failure s ->

| e ->

)

else

(

[] -> []

| ele :: q ->

match ele with

(** Remove the class elements after the stop special comment in a class kind. *)

let rec remove_class_elements_after_stop_in_class_kind k =

| Odoc_class.Class_constr _ -> k

| Odoc_class.Class_constraint (k1, ctk) ->

Odoc_class.Class_constraint (remove_class_elements_after_stop_in_class_kind k1,

(** Remove the class elements after the stop special comment in a class type kind. *)

and remove_class_elements_after_stop_in_class_type_kind tk =

[] -> []

| ele :: q ->

match ele with

| Odoc_module.Element_included_module _ ->

| Odoc_module.Element_class c ->

| Odoc_module.Element_class_type ct ->

| Odoc_module.Element_value _

| Odoc_module.Element_exception _

| Odoc_module.Element_type _ ->

(** Remove the module elements after the stop special comment, in the given module kind. *)

Odoc_module.Module_functor (params, remove_module_elements_after_stop_in_module_kind k2)

| Odoc_module.Module_apply (k1, k2) ->

Odoc_module.Module_apply (remove_module_elements_after_stop_in_module_kind k1,

| Odoc_module.Module_with (mtkind, s) ->

Odoc_module.Module_with (remove_module_elements_after_stop_in_module_type_kind mtkind, s)

| Odoc_module.Module_constraint (k2, mtkind) ->

Odoc_module.Module_constraint (remove_module_elements_after_stop_in_module_kind k2,

(** Remove the module elements after the stop special comment, in the given module type kind. *)

and remove_module_elements_after_stop_in_module_type_kind tk =

init @

(List.fold_left

(fun acc -> fun file ->

)

[]

files

val analyse_files :

?init: Odoc_module.t_module list ->

string list ->

(** Dump of a list of modules into a file.

@raise Failure if an error occurs.*)

List.fold_left

(fun acc -> fun ((c,_), v) ->

if String.contains s c then

else

[]

l

(fun n ->

let name = Str.global_replace (Str.regexp "[ \n\r\t]+") "" n in

match name with

)

l

let rec iter = function

[] -> [o]

| (s2,f,m) :: q ->

in

options := iter !options

val parse :

html_generator:doc_generator ->

latex_generator:doc_generator ->

module Typedtree_search =

struct

type ele =

type tab = (ele, Typedtree.structure_item) Hashtbl.t

type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t

let add_to_hashes table table_values tt =

match tt with

| Typedtree.Tstr_module (ident, _) ->

let tables typedtree =

let t = Hashtbl.create 13 in

let search_module table name =

match Hashtbl.find table (M name) with

let search_module_type table name =

match Hashtbl.find table (MT name) with

let search_exception_rebind table name =

match Hashtbl.find table (ER name) with

| (Typedtree.Tstr_exn_rebind (_, p)) -> p

let search_type_declaration table name =

match Hashtbl.find table (T name) with

| (Typedtree.Tstr_type [(_,decl)]) -> decl

let search_class_exp table name =

match Hashtbl.find table (C name) with

| (Typedtree.Tstr_class [(_,_,_,ce)]) ->

let search_class_type_declaration table name =

match Hashtbl.find table (CT name) with

| (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl

let search_value table name = Hashtbl.find table name

let search_primitive table name =

match Hashtbl.find table (P name) with

let get_nth_inherit_class_expr cls n =

let rec iter cpt = function

in

iter 0 cls.Typedtree.cl_field

let search_attribute_type cls name =

let rec iter = function

in

iter cls.Typedtree.cl_field

let search_method_expression cls name =

let rec iter = function

in

iter cls.Typedtree.cl_field

end

*)

let tt_param_info_from_pattern env f_desc pat =

let rec iter_pattern pat =

(* implicit pattern matching -> anonymous parameter *)

in

iter_pattern pat

the (pattern, expression) structures encountered. *)

let rec tt_analyse_function_parameters env current_comment_opt pat_exp_list =

match pat_exp_list with

(* implicit pattern matching -> anonymous parameter and no more parameter *)

| (pattern_param, func_body) :: [] ->

(* For optional parameters with a default value, a special treatment is required *)

(* we look if the name of the parameter we just add is "*opt*", which means

(* continue if the body is still a function *)

(* something else ; no more parameter *)

(** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value].

let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =

let (pat, exp) = pat_exp in

match (pat.pat_desc, exp.exp_desc) with

(* a new function is defined *)

| (Typedtree.Tpat_var ident, _) ->

| (Typedtree.Tpat_tuple lpat, _) ->

| _ ->

(** This function takes a Typedtree.class_expr and returns a string which can stand for the class name.

The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *)

let rec tt_name_of_class_expr clexp =

match clexp.Typedtree.cl_desc with

(*

*)

(** Analysis of a method expression to get the method parameters.

@param first indicates if we're analysing the method for

*)

let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =

match exp.Typedtree.exp_desc with

(* implicit pattern matching -> anonymous parameter *)

(* For optional parameters with a default value, a special treatment is required. *)

(* We look if the name of the parameter we just add is "*opt*", which means

| _ ->

(** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple

(inherited classes, class elements). *)

let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls =

let rec iter acc_inher acc_fields last_pos = function

in

iter [] [] last_pos (snd p_cls)

(** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)

let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp =

match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with

(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( m�me quand on a class tutu = toto *)

| (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) ->

| (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),

| _ ->

| (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) ->

(* we want an ident, or else the class applied will appear in the form object ... end,

(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( m�me quand on a class tutu = toto *)

| (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) ->

| (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),

(** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*)

let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp =

let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in

let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in

let (parameters, kind) = analyse_class_kind

in

let cl =

in

cl

is not an ident of a constraint on an ident. *)

let rec tt_name_from_module_expr mod_expr =

match mod_expr.Typedtree.mod_desc with

| Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp

| Typedtree.Tmod_structure _

| Typedtree.Tmod_functor _

| Typedtree.Tmod_apply _ ->

(** Get the list of included modules in a module structure of a typed tree. *)

let tt_get_included_module_list tt_structure =

let f acc item =

in

List.fold_left f [] tt_structure

the ones found in typed tree structure of the module. *)

let replace_dummy_included_modules module_elements included_modules =

let rec f = function

in

f (module_elements, included_modules)

print_DEBUG "Odoc_ast:analyse_struture";

let (table, table_values) = Typedtree_search.tables typedtree in

let rec iter env last_pos = function

in

iter env last_pos parsetree

(** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*)

and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree

print_DEBUG "Odoc_ast:analyse_struture_item";

match parsetree_item_desc with

| Parsetree.Pstr_value (rec_flag, pat_exp_list) ->

| Parsetree.Pstr_primitive (name_pre, val_desc) ->

| Parsetree.Pstr_type name_typedecl_list ->

| Parsetree.Pstr_exception (name, excep_decl) ->

| Parsetree.Pstr_exn_rebind (name, _) ->

| Parsetree.Pstr_module (name, module_expr) ->

(* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on aurait pas la signature *)

| Parsetree.Pstr_modtype (name, modtype) ->

(* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on n'aurait pas la signature *)

| Parsetree.Pstr_open longident ->

| Parsetree.Pstr_class class_decl_list ->

(* we start by extending the environment *)

| Parsetree.Pstr_class_type class_type_decl_list ->

| Parsetree.Pstr_include module_expr ->

(** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*)

and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr =

let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end in

let modtype = tt_module_expr.Typedtree.mod_type in

let m_base =

in

match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with

| (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_structure tt_structure) ->

| (Parsetree.Pmod_functor (_, _, p_module_expr2),

| (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),

| (Parsetree.Pmod_constraint (p_module_expr2, p_modtype),

*)

let analyse_typed_tree source_file input_file

let (tree_structure, _) = typedtree in

let complete_source_file =

in

prepare_file complete_source_file input_file;

(* We create the t_module for this file. *)

let elements2 = replace_dummy_included_modules elements included_modules_from_tt in

let kind = Module_struct elements2 in

let m =

in

m

end

val tables : Typedtree.structure_item list -> tab * tab_values

(** This function returns the [Typedtree.module_expr] associated to the given module name,

val search_module : tab -> string -> Typedtree.module_expr

(** This function returns the [Types.module_type] associated to the given module type name,

val search_module_type : tab -> string -> Types.module_type

(** This function returns the [Types.exception_declaration] associated to the given exception name,

val search_exception : tab -> string -> Types.exception_declaration

(** This function returns the [Path.t] associated to the given exception rebind name,

val search_exception_rebind : tab -> string -> Path.t

(** This function returns the [Typedtree.type_declaration] associated to the given type name,

val search_type_declaration : tab -> string -> Types.type_declaration

(** This function returns the [Typedtree.class_expr] and type parameters

val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list))

(** This function returns the [Types.cltype_declaration] associated to the given class type name,

val search_class_type_declaration : tab -> string -> Types.cltype_declaration

(** This function returns the couple (pat, exp) for the given value name, in the

val search_value : tab_values -> string -> Typedtree.pattern * Typedtree.expression

(** This function returns the [type_expr] for the given primitive name, in the

val search_primitive : tab -> string -> Types.type_expr

(** This function returns the [Typedtree.class_expr] associated to

val get_nth_inherit_class_expr :

(** This function returns the [Types.type_expr] of the attribute

val search_attribute_type :

(** This function returns the [Types.expression] of the method whose name is given, in a given class structure.

val search_method_expression :

end

(** The module which performs the analysis of a typed tree.

functor (My_ir : Odoc_sig.Info_retriever) ->

sig

(** This function takes a file name, a file containg the code and

val analyse_typed_tree :

string -> string -> Parsetree.structure -> typedtree -> Odoc_module.t_module

end

and class_kind =

Class_structure of inherited_class list * class_element list

| Class_apply of class_apply (** application/alias of a class, used in implementation only *)

| Class_constr of class_constr (** a class used to give the type of the defined class,

| Class_constraint of class_kind * class_type_kind

(** Representation of a class. *)

and t_class = {

None -> None

| Some i ->

try

with

(** Returns the list of elements of a t_class. *)

let rec class_elements ?(trans=true) cl =

match k with

Class_structure (_, elements) -> elements

| Class_constraint (c_kind, ct_kind) ->

(* A VOIR : utiliser le c_kind ou le ct_kind ?

*)

| Class_apply capp ->

| Class_constr cco ->

in

iter_kind cl.cl_kind

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_elements ~trans cl)

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_elements ~trans cl)

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_elements ~trans cl)

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_type_elements ~trans clt)

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_type_elements ~trans clt)

List.fold_left

(fun acc -> fun ele ->

match ele with

| _ ->

)

[]

(class_type_elements ~trans clt)

None -> None

| Some i ->

try

with

struct

let create_see s =

try

with

let retrieve_info fun_lex file (s : string) =

try

(** This function takes a string where a simple comment may has been found. It returns

false if there is a blank line or the first comment is a special one, or if there is

let nothing_before_simple_comment s =

(* get the position of the first "(*" *)

try

(* there is no special comment between the constructor and the coment we got *)

(* a blank line was before the comment *)

with

(** Return true if the given string contains a blank line. *)

let blank_line s =

try

(* a blank line was before the comment *)

with

let retrieve_info_special file (s : string) =

retrieve_info Odoc_lexer.main file s

Odoc_lexer.comments_level := 0;

let lexbuf = Lexing.from_string s in

match Odoc_parser.main Odoc_lexer.simple lexbuf with

| Some (desc, remain_opt) ->

(** Return true if the given string contains a blank line outside a simple comment. *)

let blank_line_outside_simple file s =

let rec iter s2 =

in

iter s

comment is found before the simple comment. *)

let retrieve_first_info_simple ?(strict=true) file (s : string) =

match retrieve_info_simple file s with

let retrieve_last_info_simple file (s : string) =

print_DEBUG ("retrieve_last_info_simple:"^s);

let rec f cur_len cur_d =

in

f 0 None

let retrieve_last_special_no_blank_after file (s : string) =

print_DEBUG ("retrieve_last_special_no_blank_after:"^s);

let rec f cur_len cur_d =

in

f 0 None

let all_special file s =

print_DEBUG ("all_special: "^s);

let rec iter acc n s2 =

in

let res = iter [] 0 s in

print_DEBUG ("all_special: end");

let just_after_special file s =

print_DEBUG ("just_after_special: "^s);

let res = match retrieve_info_special file s with

in

print_DEBUG ("just_after_special:end");

res

let get_comments f_create_ele file s =

let (assoc_com, ele_coms) =

(* get the comments *)

in

let ele_comments =

in

(assoc_com, ele_comments)

end

[str] to the end of the special comment. *)

val first_special :

string -> string -> int * Odoc_types.info option

(** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special

comment found in the given string and not followed by a blank line,

and [element_comment_list] the list of values built from the other

let p_module m _ =

(true,

match m.m_kind with

| _ -> false

)

let p_module_type mt _ =

(true,

match mt.mt_kind with

| _ -> false

)

let p_class c _ = (false, false)

(acc_m, acc_mt, acc_ex)

| (Odoc_search.Res_module m) :: q ->

let new_acc_m =

in

build_alias_list (new_acc_m, acc_mt, acc_ex) q

| (Odoc_search.Res_module_type mt) :: q ->

let new_acc_mt =

in

build_alias_list (acc_m, new_acc_mt, acc_ex) q

| (Odoc_search.Res_exception e) :: q ->

let new_acc_ex =

in

build_alias_list (acc_m, acc_mt, new_acc_ex) q

| _ :: q ->

let rec lookup_module module_list name =

let l = List.filter

(fun res ->

)

(Search_by_complete_name.search module_list name)

in

let rec lookup_module_type module_list name =

let l = List.filter

(fun res ->

)

(Search_by_complete_name.search module_list name)

in

let rec lookup_class module_list name =

let l = List.filter

(fun res ->

)

(Search_by_complete_name.search module_list name)

in

let rec lookup_class_type module_list name =

let l = List.filter

(fun res ->

)

(Search_by_complete_name.search module_list name)

in

let rec lookup_exception module_list name =

let l = List.filter

(fun res ->

)

(Search_by_complete_name.search module_list name)

in

let rec iter_kind (acc_b, acc_inc, acc_names) k =

match k with

Module_struct elements ->

| Module_alias ma ->

| Module_functor (_, k) ->

| Module_with (tk, _) ->

| Module_apply (k1, k2) ->

| Module_constraint (k, tk) ->

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 ->

| Module_type_functor (_, k) ->

| Module_type_with (k, _) ->

| Module_type_alias mta ->

in

match mt.mt_kind with

None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found)

| 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 ->

(

)

| 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_exception ex ->

(

)

| 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)

let rec iter_kind (acc_b, acc_inc, acc_names) k =

match k with

Class_structure (inher_l, _) ->

| Class_apply capp ->

| Class_constr cco ->

| Class_constraint (ckind, ctkind) ->

in

iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind

let rec iter_kind (acc_b, acc_inc, acc_names) k =

match k with

Class_signature (inher_l, _) ->

| Class_type cta ->

in

iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind

| Left t -> Left (assoc_comments_text module_list t)

| Right t -> Right (assoc_comments_text module_list t)

| Emphasize t -> Emphasize (assoc_comments_text module_list t)

| Newline -> Newline

| Block t -> Block (assoc_comments_text module_list t)

| Superscript t -> Superscript (assoc_comments_text module_list t)

| Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text module_list t))

| Link (s, t) -> Link (s, (assoc_comments_text module_list t))

| Ref (name, None) ->

and assoc_comments_text module_list text =

List.map (assoc_comments_text_elements module_list) text

mk

| Module_apply (mk1, mk2) ->

Module_apply (assoc_comments_module_kind module_list mk1,

| Module_with (mtk, s) ->

Module_with (assoc_comments_module_type_kind module_list mtk, s)

| Module_constraint (mk1, mtk) ->

Module_constraint (assoc_comments_module_kind module_list mk1,

and assoc_comments_module_type_kind module_list mtk =

match mtk with

match ck with

Class_structure (inher, eles) ->

let inher2 =

in

Class_structure (inher2, List.map (assoc_comments_class_element module_list) eles)

| Class_constr _ -> ck

| Class_constraint (ck1, ctk) ->

Class_constraint (assoc_comments_class_kind module_list ck1,

and assoc_comments_class_type_kind module_list ctk =

match ctk with

Class_signature (inher, eles) ->

let inher2 =

in

Class_signature (inher2, List.map (assoc_comments_class_element module_list) eles)

Type_abstract -> ()

| Type_variant vl ->

List.iter

| Type_record fl ->

List.iter

);

t

let rec remove_doubles acc = function

[] -> acc

| h :: q ->

in

let rec iter incomplete_modules =

let (b_modif, remaining_inc_modules, acc_names_not_found) =

in

let remaining_no_doubles = remove_doubles [] remaining_inc_modules in

let remaining_modules = List.filter

in

if b_modif then

(* we may be able to associate something else *)

()

| l ->

List.iter

) ;

(* Find a type for each name of element which is referenced in comments. *)

let _ = associate_type_of_elements_in_comments module_list in

()

let all_classes =

let rec iter list2 =

List.fold_left

in

iter list

in

let rec distinct acc = function

[] ->

acc

in

let distinct_classes = distinct [] all_classes in

let liste_index =

let rec f n = function

in

f 0 distinct_classes

in

(* create the dag array, filling parents and values *)

let fmap (name, cct_opt) =

{ pare = List.map

valu = (name, cct_opt) ;

chil = []

}

let fiter i node =

let l = Array.to_list dag.dag in

let l2 = List.map (fun n -> n.valu)

in

node.chil <- List.map (fun (name,_) -> List.assoc name liste_index) l2

in

val create_class_dag :

Odoc_info.Class.t_class list ->

Odoc_info.Class.t_class_type list ->

!l

type node = {

}

type graph = node list

let make_node s children =

let set = List.fold_right

in

{ id = s;

}

let get_node graph s =

try List.find (fun n -> n.id = s) graph

with Not_found ->

let rec trans_closure graph acc n =

if S.mem n.id acc then

else

let node_trans_closure graph n =

let far = List.map

in

n.far <- far

let prune_node graph node =

S.iter

if node.reflex then

else

let kernel graph =

(* compute transitive closure *)

T.Type_abstract -> ()

| T.Type_variant cl ->

List.iter

| T.Type_record rl ->

List.iter

);

(match t.T.ty_manifest with

(fun m ->

let node = Dep.get_node k m.Module.m_name in

m.Module.m_top_deps <-

modules

(** Return the list of dependencies between the given types,

if kernel then

(

let graph = List.map

in

let k = Dep.kernel graph in

List.map

)

else

deps_pre

method get_one_color =

match colors with

method node_color s =

try Some (List.assoc s loc_colors)

with

method print_module_atts fmt m =

match self#node_color (Filename.dirname m.Module.m_file) with

method print_type_atts fmt t =

match self#node_color (Name.father t.Type.ty_name) with

method print_one_dep fmt src dest =

F.fprintf fmt "\"%s\" -> \"%s\";\n" src dest

method generate_for_module fmt m =

let l = List.filter

in

self#print_module_atts fmt m;

List.iter (self#print_one_dep fmt m.Module.m_name) l

method generate_for_type fmt (t, l) =

self#print_type_atts fmt t;

List.iter

method generate_types types =

try

with

method generate_modules modules_list =

try

with

(** Generate the dot code in the file {!Odoc_args.out_file}. *)

method generate (modules_list : Odoc_info.Module.t_module list) =

if !Odoc_args.dot_types then

else

end

| Types.Tsig_type (ident,_ ) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }

| Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions }

| Types.Tsig_module (ident, modtype) ->

| Types.Tsig_modtype (ident, modtype_decl) ->

| Types.Tsig_class (ident, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes }

| Types.Tsig_cltype (ident, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types }

in

Btype.iter_type_expr iter t;

match t.Types.desc with

| Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option ->

| Types.Tconstr (p, l, a) ->

Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in

| Types.Tobject (_, ({contents=Some(p,tyl)} as r)) ->

Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in

r := Some (new_p, tyl)

| Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) ->

Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in

Types.Tvariant {row with Types.row_name=Some(new_p, tyl)}

| _ ->

()

let rec iter t =

match t with

Types.Tmty_ident p ->

| Types.Tmty_signature _ ->

| Types.Tmty_functor (id, mt1, mt2) ->

in

iter t

let rec iter t =

match t with

Types.Tcty_constr (p,texp_list,ct) ->

| Types.Tcty_signature cs ->

| Types.Tcty_fun (l, texp, ct) ->

in

iter t

let complete_target pref complete_name =

let simple_name = Name.simple complete_name in

let module_name =

in

let (html_file, _) = html_files module_name in

html_file^"#"^(target pref simple_name)

let len = String.length s in

let buf = Buffer.create len in

for i = 0 to len - 1 do

done;

Buffer.contents buf

from the title level and the first sentence of the title.*)

method create_title_label (n,label_opt,t) =

match label_opt with

(** Return the html code corresponding to the [text] parameter. *)

method html_of_text t = String.concat "" (List.map self#html_of_text_element t)

method html_of_text_element te =

print_DEBUG "text::html_of_text_element";

match te with

method html_of_Raw s = self#escape s

method html_of_Code s =

if !Odoc_args.colorize_code then

else

method html_of_CodePre s =

if !Odoc_args.colorize_code then

else

method html_of_Verbatim s = "<pre>"^(self#escape s)^"</pre>"

method html_of_Bold t = "<b>"^(self#html_of_text t)^"</b>"

method html_of_List tl =

"<ul>\n"^

(String.concat ""

"</ul>\n"

method html_of_Enum tl =

"<OL>\n"^

(String.concat ""

"</OL>\n"

method html_of_Newline = "\n<p>\n"

method html_of_Ref name ref_opt =

match ref_opt with

method html_of_Superscript t =

"<sup class=\"superscript\">"^(self#html_of_text t)^"</sup>"

(** Return html for an author list. *)

method html_of_author_list l =

match l with

| _ ->

(** Return html code for the given optional version information.*)

method html_of_version_opt v_opt =

match v_opt with

| Some v -> "<b>"^Odoc_messages.version^": </b>"^v^"<br>\n"

(** Return html code for the given optional since information.*)

method html_of_since_opt s_opt =

match s_opt with

| Some s -> "<b>"^Odoc_messages.since^"</b> "^s^"<br>\n"

(** Return html code for the given list of raised exceptions.*)

method html_of_raised_exceptions l =

match l with

| (s, t) :: [] -> "<b>"^Odoc_messages.raises^"</b> <code>"^s^"</code> "^(self#html_of_text t)^"<br>\n"

| _ ->

(** Return html code for the given "see also" reference. *)

method html_of_see (see_ref, t) =

let t_ref =

in

self#html_of_text t_ref

(** Return html code for the given list of "see also" references.*)

method html_of_sees l =

match l with

| see :: [] -> "<b>"^Odoc_messages.see_also^"</b> "^(self#html_of_see see)^"<br>\n"

| _ ->

(** Return html code for the given optional return information.*)

method html_of_return_opt return_opt =

match return_opt with

| Some s -> "<b>"^Odoc_messages.returns^"</b> "^(self#html_of_text s)^"<br>\n"

(** Return html code for the given list of custom tagged texts. *)

method html_of_custom l =

let buf = Buffer.create 50 in

List.iter

Buffer.contents buf

(** Return html code for a description, except for the [i_params] field. *)

method html_of_info info_opt =

match info_opt with

| Some info ->

(** Return html code for the first sentence of a description.

The titles and lists in this first sentence has been removed.*)

method html_of_info_first_sentence info_opt =

match info_opt with

| Some info ->

end

(** The default style options. *)

val mutable default_style_options =

["a:visited {color : #416DFF; text-decoration : none; }" ;

(** The style file for all pages. *)

val mutable style_file = "style.css"

(** Init the style. *)

method init_style =

(match !Odoc_args.css_style with

| Some f ->

);

style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n"

(** A function to build the header of pages. *)

method prepare_header module_list =

let f ?(nav=None) ?(comments=[]) t =

in

header <- f

method html_sections_links comments =

let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in

let levels =

in

let sorted_levels = List.sort compare levels in

let (section_level, subsection_level) =

in

let titles_per_level level_opt =

in

let section_titles = titles_per_level section_level in

let subsection_titles = titles_per_level subsection_level in

let create_lines s_rel titles =

in

let section_lines = create_lines "Section" section_titles in

let subsection_lines = create_lines "Subsection" subsection_titles in

method navbar pre post name =

"<div class=\"navbar\">"^

(match pre with

| Some name ->

)^

"&nbsp;"^

(

)^

"&nbsp;"^

(match post with

| Some name ->

)^

"</div>\n"

(** Output the given ocaml code to the given file name. *)

method private output_code in_title file code =

try

with

(** Take a string and return the string where fully qualified

type (or class or class type) idents

have been replaced by links to the type referenced by the ident.*)

method create_fully_qualified_idents_links m_name s =

let f str_t =

in

let s2 = Str.global_substitute

in

s2

have been replaced by links to the module referenced by the ident.*)

method create_fully_qualified_module_idents_links m_name s =

let f str_t =

in

let s2 = Str.global_substitute

in

s2

(** Return html code to display a [Types.type_expr].*)

method html_of_type_expr m_name t =

let s = String.concat "\n"

in

let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in

"<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"

(** Return html code to display a [Types.class_type].*)

method html_of_class_type_expr m_name t =

let s = String.concat "\n"

in

let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in

"<code class=\"type\">"^(self#create_fully_qualified_idents_links m_name s2)^"</code>"

(** Return html code to display a [Types.module_type]. *)

method html_of_module_type m_name t =

let s = String.concat "\n"

in

let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in

"<code class=\"type\">"^(self#create_fully_qualified_module_idents_links m_name s2)^"</code>"

(** Generate a file containing the module type in the given file name. *)

method output_module_type in_title file mtyp =

let s = String.concat "\n"

in

self#output_code in_title file s

(** Generate a file containing the class type in the given file name. *)

method output_class_type in_title file ctyp =

let s = String.concat "\n"

in

self#output_code in_title file s

(* html mark *)

"<a name=\""^(Naming.value_target v)^"\"></a>"^

(match v.val_code with

| Some c ->

)^" : "^

(self#html_of_type_expr (Name.father v.val_name) v.val_type)^"</pre>"^

(self#html_of_info v.val_info)^

(if !Odoc_args.with_parameter_list then

else

)

(** Return html code for an exception. *)

"<a name=\""^(Naming.exception_target e)^"\"></a>"^

(Name.simple e.ex_name)^

(match e.ex_args with

)^

(match e.ex_alias with

| Some ea -> " = "^

)^

"</pre>\n"^

(self#html_of_info e.ex_info)

(* html mark *)

"<a name=\""^(Naming.type_target t)^"\"></a>"^

(match t.ty_parameters with

)^

(Name.simple t.ty_name)^" "^

(match t.ty_manifest with None -> "" | Some typ -> "= "^(self#html_of_type_expr father typ)^" ")^

(match t.ty_kind with

)^"\n"^

(self#html_of_info t.ty_info)^

"<br>\n"

"<a name=\""^(Naming.attribute_target a)^"\"></a>"^

(if a.att_mutable then (self#keyword Odoc_messages.mutab)^" " else "")^

(match a.att_value.val_code with

| Some c ->

)^" : "^

(self#html_of_type_expr module_name a.att_value.val_type)^"</pre>"^

(self#html_of_info a.att_value.val_info)

(if m.met_private then (self#keyword "private")^" " else "")^

(if m.met_virtual then (self#keyword "virtual")^" " else "")^

(match m.met_value.val_code with

| Some c ->

)^" : "^

(self#html_of_type_expr module_name m.met_value.val_type)^"</pre>"^

(self#html_of_info m.met_value.val_info)^

(if !Odoc_args.with_parameter_list then

else

)

(** Return html code for the description of a function parameter. *)

method html_of_parameter_description p =

match Parameter.names p with

| name :: [] ->

(* Only one name, no need for label for the description. *)

| l ->

(* A list of names, we display those with a description. *)

(** Return html code for a list of parameters. *)

method html_of_parameter_list m_name l =

match l with

| _ ->

(** Return html code for the parameters which have a name and description. *)

method html_of_described_parameter_list m_name l =

(* get the params which have a name, and at least one name described. *)

let l2 = List.filter

in

let f p =

in

match l2 with

(** Return html code for a list of module parameters. *)

method html_of_module_parameter_list m_name l =

match l with

| _ ->

(** Return html code for a module. *)

method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m =

p buf "<pre>%s " (self#keyword "module");

(

if with_link then

else

);

p buf ": %s</pre>" (self#html_of_module_type father m.m_type);

if info then

else

Buffer.contents buf

(** Return html code for a module type. *)

p buf "<pre>%s " (self#keyword "module type");

(

if with_link then

);

(match mt.mt_type with

);

Buffer.add_string buf "</pre>";

if info then

else

Buffer.contents buf

(** Return html code for an included module. *)

"<pre>"^(self#keyword "include")^" "^

(

match im.im_module with

| Some mmt ->

)^

"</pre>\n"

let p = Printf.bprintf in

p buf "<pre>%s " (self#keyword "class");

(* we add a html tag, the same as for a type so we can

p buf "<a name=\"%s\"></a>"

print_DEBUG "html#html_of_class : virtual or not" ;

if c.cl_virtual then p buf "%s " (self#keyword "virtual") else ();

(

match c.cl_type_parameters with

| l ->

);

print_DEBUG "html#html_of_class : with link or not" ;

(

if with_link then

else

);

Buffer.add_string buf " : " ;

Buffer.add_string buf "</pre>" ;

print_DEBUG "html#html_of_class : info" ;

Buffer.add_string buf

Buffer.contents buf

(** Return html code for a class type. *)

let (html_file, _) = Naming.html_files ct.clt_name in

p buf "<pre>%s " (self#keyword "class type");

(* we add a html tag, the same as for a type so we can

p buf "<a name=\"%s\"></a>"

if ct.clt_virtual then p buf "%s "(self#keyword "virtual") else ();

(

match ct.clt_type_parameters with

);

if with_link then

else

Buffer.add_string buf " = ";

Buffer.add_string buf (self#html_of_class_type_expr father ct.clt_type);

(** Return html code to represent a dag, represented as in Odoc_dag2html. *)

method html_of_dag dag =

let f n =

in

let a = Array.map f dag.Odoc_dag2html.dag in

Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a }

method html_of_class_comment text =

(* Add some style if there is no style for the first part of the text. *)

let text2 =

in

self#html_of_text text2

(** Generate html code for the given list of inherited classes.*)

method generate_inheritance_info chanout inher_l =

let f inh =

in

let text = [

]

in

let html = self#html_of_text text in

(** Generate html code for the inherited classes of the given class. *)

method generate_class_inheritance_info chanout cl =

let rec iter_kind k =

in

iter_kind cl.cl_kind

(** Generate html code for the inherited classes of the given class type. *)

method generate_class_type_inheritance_info chanout clt =

match clt.clt_kind with

(** A method to create index files. *)

method generate_elements_index :

fun elements name info target title simple_file ->

try

with

(** A method to generate a list of module/class files. *)

method generate_elements :

fun f_generate l ->

(** Generate the code of the html page for the given class.*)

method generate_for_class pre post cl =

let (html_file, _) = Naming.html_files cl.cl_name in

let type_file = Naming.file_type_class_complete_target cl.cl_name in

try

(* class inheritance *)

(* generate the file with the complete class type *)

with

(** Generate the code of the html page for the given class type.*)

method generate_for_class_type pre post clt =

let (html_file, _) = Naming.html_files clt.clt_name in

let type_file = Naming.file_type_class_complete_target clt.clt_name in

try

(* class inheritance *)

(* generate the file with the complete class type *)

with

(** Generate the html file for the given module type.

@raise Failure if an error occurs.*)

method generate_for_module_type pre post mt =

try

(* generate html files for submodules *)

(* generate html files for module types *)

(* generate html files for classes *)

(* generate html files for class types *)

(* generate the file with the complete module type *)

with

(** Generate the html file for the given module.

@raise Failure if an error occurs.*)

method generate_for_module pre post modu =

try

(* generate html files for submodules *)

(* generate html files for module types *)

(* generate html files for classes *)

(* generate html files for class types *)

(* generate the file with the complete module type *)

with

(** Generate the [index.html] file corresponding to the given module list.

@raise Failure if an error occurs.*)

method generate_index module_list =

try

with

(** Generate the values index in the file [index_values.html]. *)

method generate_values_index module_list =

self#generate_elements_index

(** Generate the exceptions index in the file [index_exceptions.html]. *)

method generate_exceptions_index module_list =

self#generate_elements_index