diff options
Diffstat (limited to 'ocamldoc/odoc_html.ml')
-rw-r--r-- | ocamldoc/odoc_html.ml | 1962 |
1 files changed, 1962 insertions, 0 deletions
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml new file mode 100644 index 000000000..3b066eb7a --- /dev/null +++ b/ocamldoc/odoc_html.ml @@ -0,0 +1,1962 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + +(** Generation of html documentation. *) + +let print_DEBUG s = print_string s ; print_newline () + +open Odoc_info +open Parameter +open Value +open Type +open Exception +open Class +open Module + + +(** The functions used for naming files and html marks.*) +module Naming = + struct + (** The prefix for types marks. *) + let mark_type = "TYPE" + (** The prefix for functions marks. *) + let mark_function = "FUN" + (** The prefix for exceptions marks. *) + let mark_exception = "EXCEPTION" + (** The prefix for values marks. *) + let mark_value = "VAL" + (** The prefix for attributes marks. *) + let mark_attribute = "ATT" + (** The prefix for methods marks. *) + let mark_method = "METHOD" + + (** The prefix for code files.. *) + let code_prefix = "code_" + (** The prefix for type files.. *) + let type_prefix = "type_" + + (** Return the two html files names for the given module or class name.*) + let html_files name = + let html_file = name^".html" in + let html_frame_file = name^"-frame.html" in + (html_file, html_frame_file) + + (** Return the target for the given prefix and simple name. *) + let target pref simple_name = pref^simple_name + (** Return the complete link target (file#target) for the given prefix string and complete name.*) + let complete_target pref complete_name = + let simple_name = Name.simple complete_name in + let module_name = + let s = Name.father complete_name in + if s = "" then simple_name else s + in + let (html_file, _) = html_files module_name in + html_file^"#"^(target pref simple_name) + + (** Return the link target for the given type. *) + let type_target t = target mark_type (Name.simple t.ty_name) + (** Return the complete link target for the given type. *) + let complete_type_target t = complete_target mark_type t.ty_name + + (** Return the link target for the given exception. *) + let exception_target e = target mark_exception (Name.simple e.ex_name) + (** Return the complete link target for the given exception. *) + let complete_exception_target e = complete_target mark_exception e.ex_name + + (** Return the link target for the given value. *) + let value_target v = target mark_value (Name.simple v.val_name) + (** Return the complete link target for the given value. *) + let complete_value_target v = complete_target mark_value v.val_name + (** Return the complete filename for the code of the given value. *) + let file_code_value_complete_target v = + let f = code_prefix^mark_value^v.val_name^".html" in + f + + (** Return the link target for the given attribute. *) + let attribute_target a = target mark_attribute (Name.simple a.att_value.val_name) + (** Return the complete link target for the given attribute. *) + let complete_attribute_target a = complete_target mark_attribute a.att_value.val_name + (** Return the complete filename for the code of the given attribute. *) + let file_code_attribute_complete_target a = + let f = code_prefix^mark_attribute^a.att_value.val_name^".html" in + f + + (** Return the link target for the given method. *) + let method_target m = target mark_method (Name.simple m.met_value.val_name) + (** Return the complete link target for the given method. *) + let complete_method_target m = complete_target mark_method m.met_value.val_name + (** Return the complete filename for the code of the given method. *) + let file_code_method_complete_target m = + let f = code_prefix^mark_method^m.met_value.val_name^".html" in + f + + (** Return the link target for the given label section. *) + let label_target l = target "" l + (** Return the complete link target for the given section label. *) + let complete_label_target l = complete_target "" l + + (** Return the complete filename for the code of the type of the + given module or module type name. *) + let file_type_module_complete_target name = + let f = type_prefix^name^".html" in + f + + (** Return the complete filename for the code of the type of the + given class or class type name. *) + let file_type_class_complete_target name = + let f = type_prefix^name^".html" in + f + end + +(** A class with a method to colorize a string which represents OCaml code. *) +class ocaml_code = + object(self) + method html_of_code ?(with_pre=true) code = + let html_code = Odoc_ocamlhtml.html_of_code ~with_pre: with_pre code in + html_code + end + + +(** Generation of html code from text structures. *) +class text = + object (self) + (** We want to display colorized code. *) + inherit ocaml_code + + (** Escape the strings which would clash with html syntax, and + make some replacements (double newlines replaced by <br>). *) + method escape s = Odoc_ocamlhtml.escape_base s + + (** Return the html code corresponding to the [text] parameter. *) + method html_of_text t = String.concat "" (List.map self#html_of_text_element t) + + (** Return the html code for the [text_element] in parameter. *) + method html_of_text_element te = + print_DEBUG "text::html_of_text_element"; + match te with + | Odoc_info.Raw s -> self#html_of_Raw s + | Odoc_info.Code s -> self#html_of_Code s + | Odoc_info.CodePre s -> self#html_of_CodePre s + | Odoc_info.Verbatim s -> self#html_of_Verbatim s + | Odoc_info.Bold t -> self#html_of_Bold t + | Odoc_info.Italic t -> self#html_of_Italic t + | Odoc_info.Emphasize t -> self#html_of_Emphasize t + | Odoc_info.Center t -> self#html_of_Center t + | Odoc_info.Left t -> self#html_of_Left t + | Odoc_info.Right t -> self#html_of_Right t + | Odoc_info.List tl -> self#html_of_List tl + | Odoc_info.Enum tl -> self#html_of_Enum tl + | Odoc_info.Newline -> self#html_of_Newline + | Odoc_info.Block t -> self#html_of_Block t + | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title n l_opt t + | Odoc_info.Latex s -> self#html_of_Latex s + | Odoc_info.Link (s, t) -> self#html_of_Link s t + | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref name ref_opt + | Odoc_info.Superscript t -> self#html_of_Superscript t + | Odoc_info.Subscript t -> self#html_of_Subscript t + + method html_of_Raw s = self#escape s + + method html_of_Code s = + if !Odoc_args.colorize_code then + self#html_of_code ~with_pre: false s + else + "<code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code>" + + method html_of_CodePre s = + if !Odoc_args.colorize_code then + self#html_of_code s + else + "<pre><code class=\""^Odoc_ocamlhtml.code_class^"\">"^(self#escape s)^"</code></pre>" + + 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_Italic t = "<i>"^(self#html_of_text t)^"</i>" + method html_of_Emphasize t = "<em>"^(self#html_of_text t)^"</em>" + method html_of_Center t = "<center>"^(self#html_of_text t)^"</center>" + method html_of_Left t = "<div align=left>"^(self#html_of_text t)^"</div>" + method html_of_Right t = "<div align=right>"^(self#html_of_text t)^"</div>" + + method html_of_List tl = + "<ul>\n"^ + (String.concat "" + (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ + "</ul>\n" + + method html_of_Enum tl = + "<OL>\n"^ + (String.concat "" + (List.map (fun t -> "<li>"^(self#html_of_text t)^"</li>\n") tl))^ + "</OL>\n" + + method html_of_Newline = "\n<p>\n" + + method html_of_Block t = + "<blockquote>\n"^(self#html_of_text t)^"</blockquote>\n" + + method html_of_Title n label_opt t = + let css_class = "title"^(string_of_int n) in + "<br>\n"^ + ( + match label_opt with + None -> "" + | Some l -> "<a name=\""^(Naming.label_target l)^"\"></a>" + )^ + "<table cellpadding=0 cellspacing=0 width=\"100%\">\n"^ + "<tr class=\""^css_class^"\"><td><div align=center>\n"^ + "<table><tr class=\""^css_class^"\">\n"^ + "<td width=\"100%\" align=center>\n"^ + "<span class=\""^css_class^"\">"^(self#html_of_text t)^"</span>\n"^ + "</td>\n</tr>\n</table>\n</div>\n</td>\n</tr>\n</table>\n" + + method html_of_Latex _ = "" + (* don't care about LaTeX stuff in HTML. *) + + method html_of_Link s t = + "<a href=\""^s^"\">"^(self#html_of_text t)^"</a>" + + method html_of_Ref name ref_opt = + match ref_opt with + None -> + self#html_of_text_element (Odoc_info.Code name) + | Some kind -> + let target = + match kind with + Odoc_info.RK_module + | Odoc_info.RK_module_type + | Odoc_info.RK_class + | Odoc_info.RK_class_type -> + let (html_file, _) = Naming.html_files name in + html_file + | Odoc_info.RK_value -> Naming.complete_target Naming.mark_value name + | Odoc_info.RK_type -> Naming.complete_target Naming.mark_type name + | Odoc_info.RK_exception -> Naming.complete_target Naming.mark_exception name + | Odoc_info.RK_attribute -> Naming.complete_target Naming.mark_attribute name + | Odoc_info.RK_method -> Naming.complete_target Naming.mark_method name + | Odoc_info.RK_section -> Naming.complete_label_target name + in + "<a href=\""^target^"\">"^ + (self#html_of_text_element (Odoc_info.Code (Odoc_info.use_hidden_modules name)))^"</a>" + + method html_of_Superscript t = + "<sup class=\"superscript\">"^(self#html_of_text t)^"</sup>" + + method html_of_Subscript t = + "<sub class=\"subscript\">"^(self#html_of_text t)^"</sub>" + + end + +(** A class used to generate html code for info structures. *) +class virtual info = + object (self) + (** The list of pairs [(tag, f)] where [f] is a function taking + the [text] associated to [tag] and returning html code. + Add a pair here to handle a tag.*) + val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list) + + (** The method used to get html code from a [text]. *) + method virtual html_of_text : Odoc_info.text -> string + + (** Return html for an author list. *) + method html_of_author_list l = + match l with + [] -> + "" + | _ -> + "<b>"^Odoc_messages.authors^": </b>"^ + (String.concat ", " l)^ + "<br>\n" + + (** Return html code for the given optional version information.*) + method html_of_version_opt v_opt = + match v_opt with + None -> "" + | 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 + None -> "" + | 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" + | _ -> + "<b>"^Odoc_messages.raises^"</b><ul>"^ + (String.concat "" + (List.map + (fun (ex, desc) -> "<li><code>"^ex^"</code> "^(self#html_of_text desc)^"</li>\n") + l + ) + )^"</ul>\n" + + (** Return html code for the given "see also" reference. *) + method html_of_see (see_ref, t) = + let t_ref = + match see_ref with + Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] + | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t + | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t + 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" + | _ -> + "<b>"^Odoc_messages.see_also^"</b><ul>"^ + (String.concat "" + (List.map + (fun see -> "<li>"^(self#html_of_see see)^"</li>\n") + l + ) + )^"</ul>\n" + + (** Return html code for the given optional return information.*) + method html_of_return_opt return_opt = + match return_opt with + None -> "" + | 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 + (fun (tag, text) -> + try + let f = List.assoc tag tag_functions in + Buffer.add_string buf (f text) + with + Not_found -> + Odoc_info.warning (Odoc_messages.tag_not_handled tag) + ) + l; + 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 + None -> + "" + | Some info -> + let module M = Odoc_info in + "<div class=\"info\">\n"^ + (match info.M.i_deprecated with + None -> "" + | Some d -> + "<span class=\"warning\">"^Odoc_messages.deprecated^"</span> "^ + (self#html_of_text d)^ + "<br>\n" + )^ + (match info.M.i_desc with + None -> "" + | Some d when d = [Odoc_info.Raw ""] -> "" + | Some d -> (self#html_of_text d)^"<br>\n" + )^ + (self#html_of_author_list info.M.i_authors)^ + (self#html_of_version_opt info.M.i_version)^ + (self#html_of_since_opt info.M.i_since)^ + (self#html_of_raised_exceptions info.M.i_raised_exceptions)^ + (self#html_of_return_opt info.M.i_return_value)^ + (self#html_of_sees info.M.i_sees)^ + (self#html_of_custom info.M.i_custom)^ + "</div>\n" + + (** Return html code for the first sentence of a description. *) + method html_of_info_first_sentence info_opt = + match info_opt with + None -> "" + | Some info -> + let module M = Odoc_info in + let dep = info.M.i_deprecated <> None in + "<div class=\"info\">\n"^ + (if dep then "<font color=\"#CCCCCC\">" else "") ^ + (match info.M.i_desc with + None -> "" + | Some d when d = [Odoc_info.Raw ""] -> "" + | Some d -> (self#html_of_text (Odoc_info.first_sentence_of_text d))^"\n" + )^ + (if dep then "</font>" else "") ^ + "</div>\n" + + end + + +(** A function used to create index files. + We must put it out of the html class because ocaml doesn't support + yet polymorphic methods :-( *) +let generate_elements_index + self_header self_inner_title self_html_of_info_first_sentence + elements name info target title simple_file = + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir simple_file) in + output_string chanout + ( + "<html>\n"^ + (self_header (self_inner_title title)) ^ + "<body>\n"^ + "<center><h1>"^title^"</h1></center>\n"); + + let sorted_elements = List.sort + (fun e1 -> fun e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) + elements + in + let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in + let f_ele e = + let simple_name = Name.simple (name e) in + let father_name = Name.father (name e) in + output_string chanout + ("<tr><td><a href=\""^(target e)^"\">"^simple_name^"</a> "^ + (if simple_name <> father_name then + "["^"<a href=\""^(fst (Naming.html_files father_name))^"\">"^father_name^"</a>]" + else + "" + )^ + "</td>\n"^ + "<td>"^(self_html_of_info_first_sentence (info e))^"</td></tr>\n" + ) + in + let f_group l = + match l with + [] -> () + | e :: _ -> + let s = + match (Char.uppercase (Name.simple (name e)).[0]) with + 'A'..'Z' as c -> String.make 1 c + | _ -> "" + in + output_string chanout ("<tr><td align=\"left\"><br>"^s^"</td></tr>\n"); + List.iter f_ele l + in + output_string chanout "<table>\n"; + List.iter f_group groups ; + output_string chanout "</table><br>\n" ; + output_string chanout "</body>\n</html>"; + close_out chanout + with + Sys_error s -> + raise (Failure s) + +(** A function used to generate a list of module/class files. + We must put it out of the html class because ocaml doesn't support + yet polymorphic methods :-( *) +let generate_elements f_generate l = + let rec iter pre_opt = function + [] -> () + | ele :: [] -> f_generate pre_opt None ele + | ele1 :: ele2 :: q -> + f_generate pre_opt (Some ele2) ele1 ; + iter (Some ele1) (ele2 :: q) + in + iter None l + +let opt = Odoc_info.apply_opt + +(** This class is used to create objects which can generate a simple html documentation. *) +class html = + object (self) + inherit text + inherit info + + (** The default style options. *) + val mutable default_style_options = + ["a:visited {color : #416DFF; text-decoration : none; }" ; + "a:link {color : #416DFF; text-decoration : none;}" ; + "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ; + "a:active {color : Red; text-decoration : underline; }" ; + ".keyword { font-weight : bold ; color : Red }" ; + ".keywordsign { color : #C04600 }" ; + ".superscript { font-size : 4 }" ; + ".subscript { font-size : 4 }" ; + ".comment { color : Green }" ; + ".constructor { color : Blue }" ; + ".string { color : Maroon }" ; + ".warning { color : Red ; font-weight : bold }" ; + ".info { margin-left : 3em; margin-right : 3em }" ; + ".code { color : black ; }" ; + ".title1 { font-size : 20pt ; background-color : #416DFF }" ; + ".title2 { font-size : 20pt ; background-color : #418DFF }" ; + ".title3 { font-size : 20pt ; background-color : #41ADFF }" ; + ".title4 { font-size : 20pt ; background-color : #41CDFF }" ; + ".title5 { font-size : 20pt ; background-color : #41EDFF }" ; + ".title6 { font-size : 20pt ; background-color : #41FFFF }" ; +(* + ".title1 { font-size : 20pt ; background-color : #AAFF44 }" ; + ".title2 { font-size : 20pt ; background-color : #AAFF66 }" ; + ".title3 { font-size : 20pt ; background-color : #AAFF99 }" ; + ".title4 { font-size : 20pt ; background-color : #AAFFCC }" ; + ".title5 { font-size : 20pt ; background-color : #AAFFFF }" ; + ".title6 { font-size : 20pt ; background-color : #DDFF44 }" ; +*) + "body { background-color : White }" ; + "tr { background-color : White }" ; + ] + + (** The style file for all pages. *) + val mutable style_file = "style.css" + + (** The code to import the style. Initialized in [init_style]. *) + val mutable style = "" + + (** The known types names. + Used to know if we must create a link to a type + when printing a type. *) + val mutable known_types_names = [] + + (** The known class and class type names. + Used to know if we must create a link to a class + or class type or not when printing a type. *) + val mutable known_classes_names = [] + + (** The known modules and module types names. + Used to know if we must create a link to a type or not + when printing a module type. *) + val mutable known_modules_names = [] + + (** The main file. *) + val mutable index = "index.html" + (** The file for the index of values. *) + val mutable index_values = "index_values.html" + (** The file for the index of types. *) + val mutable index_types = "index_types.html" + (** The file for the index of exceptions. *) + val mutable index_exceptions = "index_exceptions.html" + (** The file for the index of attributes. *) + val mutable index_attributes = "index_attributes.html" + (** The file for the index of methods. *) + val mutable index_methods = "index_methods.html" + (** The file for the index of classes. *) + val mutable index_classes = "index_classes.html" + (** The file for the index of class types. *) + val mutable index_class_types = "index_class_types.html" + (** The file for the index of modules. *) + val mutable index_modules = "index_modules.html" + (** The file for the index of module types. *) + val mutable index_module_types = "index_module_types.html" + + + (** The list of attributes. Filled in the generate method. *) + val mutable list_attributes = [] + (** The list of methods. Filled in the generate method. *) + val mutable list_methods = [] + (** The list of values. Filled in the generate method. *) + val mutable list_values = [] + (** The list of exceptions. Filled in the generate method. *) + val mutable list_exceptions = [] + (** The list of types. Filled in the generate method. *) + val mutable list_types = [] + (** The list of modules. Filled in the generate method. *) + val mutable list_modules = [] + (** The list of module types. Filled in the generate method. *) + val mutable list_module_types = [] + (** The list of classes. Filled in the generate method. *) + val mutable list_classes = [] + (** The list of class types. Filled in the generate method. *) + val mutable list_class_types = [] + + (** The header of pages. Must be prepared by the [prepare_header] method.*) + val mutable header = fun ?(nav=None) -> fun _ -> "" + + (** Init the style. *) + method init_style = + (match !Odoc_args.css_style with + None -> + let default_style = String.concat "\n" default_style_options in + ( + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir style_file) in + output_string chanout default_style ; + flush chanout ; + close_out chanout + with + Sys_error s -> + prerr_endline s ; + incr Odoc_info.errors ; + ) + | Some f -> + style_file <- f + ); + style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n" + + (** Get the title given by the user *) + method title = match !Odoc_args.title with None -> "" | Some t -> self#escape t + + (** Get the title given by the user completed with the given subtitle. *) + method inner_title s = + (match self#title with "" -> "" | t -> t^" : ")^ + (self#escape s) + + (** Get the page header. *) + method header ?nav title = header ?nav title + + (** A function to build the header of pages. *) + method prepare_header module_list = + let f ?(nav=None) t = + let link_if_not_empty l m url = + match l with + [] -> "" + | _ -> "<link title=\""^m^"\" rel=Appendix href=\""^url^"\">\n" + in + "<head>\n"^ + style^ + "<link rel=\"Start\" href=\""^index^"\">\n"^ + ( + match nav with + None -> "" + | Some (pre_opt, post_opt, name) -> + (match pre_opt with + None -> "" + | Some name -> + "<link rel=\"previous\" href=\""^(fst (Naming.html_files name))^"\">\n" + )^ + (match post_opt with + None -> "" + | Some name -> + "<link rel=\"next\" href=\""^(fst (Naming.html_files name))^"\">\n" + )^ + ( + let father = Name.father name in + let href = if father = "" then index else fst (Naming.html_files father) in + "<link rel=\"Up\" href=\""^href^"\">\n" + ) + )^ + (link_if_not_empty list_types Odoc_messages.index_of_types index_types)^ + (link_if_not_empty list_exceptions Odoc_messages.index_of_exceptions index_exceptions)^ + (link_if_not_empty list_values Odoc_messages.index_of_values index_values)^ + (link_if_not_empty list_attributes Odoc_messages.index_of_attributes index_attributes)^ + (link_if_not_empty list_methods Odoc_messages.index_of_methods index_methods)^ + (link_if_not_empty list_classes Odoc_messages.index_of_classes index_classes)^ + (link_if_not_empty list_class_types Odoc_messages.index_of_class_types index_class_types)^ + (link_if_not_empty list_modules Odoc_messages.index_of_modules index_modules)^ + (link_if_not_empty list_module_types Odoc_messages.index_of_module_types index_module_types)^ + (String.concat "\n" + (List.map + (fun m -> + let html_file = fst (Naming.html_files m.m_name) in + "<link title=\""^m.m_name^"\" rel=\"Chapter\" href=\""^html_file^"\">\n" + ) + module_list + ) + )^ + "<title>"^ + t^ + "</title>\n</head>\n" + in + header <- f + + (** Html code for navigation bar. + @param pre optional name for optinal previous module/class + @param post optional name for optinal next module/class + @param name name of current module/class *) + method navbar pre post name = + "<div class=\"navbar\">"^ + (match pre with + None -> "" + | Some name -> + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.previous^"</a>\n" + )^ + " "^ + ( + let father = Name.father name in + let href = if father = "" then index else fst (Naming.html_files father) in + "<a href=\""^href^"\">"^Odoc_messages.up^"</a>\n" + )^ + " "^ + (match post with + None -> "" + | Some name -> + "<a href=\""^(fst (Naming.html_files name))^"\">"^Odoc_messages.next^"</a>\n" + )^ + "</div>\n" + + (** Return html code with the given string in the keyword style.*) + method keyword s = + "<span class=\"keyword\">"^s^"</span>" + + (** Return html code with the given string in the constructor style. *) + method constructor s = "<span class=\"constructor\">"^s^"</span>" + + (** Output the given ocaml code to the given file name. *) + method private output_code in_title file code = + try + let chanout = open_out file in + let html_code = self#html_of_code code in + output_string chanout ("<html>"^(self#header (self#inner_title in_title))^"<body>\n"); + output_string chanout html_code; + output_string chanout "</body></html>"; + close_out chanout + with + Sys_error s -> + incr Odoc_info.errors ; + prerr_endline s + + (** 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 = + let match_s = Str.matched_string str_t in + if List.mem match_s known_types_names then + "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^ + (Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + (Name.get_relative m_name match_s) + )^"</a>" + else + if List.mem match_s known_classes_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^ + (Odoc_info.apply_if_equal + Odoc_info.use_hidden_modules + match_s + (Name.get_relative m_name match_s) + )^"</a>" + else + match_s + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Take a string and return the string where fully qualified module idents + 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 = + let match_s = Str.matched_string str_t in + if List.mem match_s known_modules_names then + let (html_file, _) = Naming.html_files match_s in + "<a href=\""^html_file^"\">"^(Name.get_relative m_name match_s)^"</a>" + else + match_s + in + let s2 = Str.global_substitute + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + f + s + in + s2 + + (** Return html code to display a [Types.type_expr].*) + method html_of_type_expr m_name t = + let s = String.concat "\n" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_type_expr t)) + 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.type_expr list].*) + method html_of_type_expr_list m_name sep l = + print_DEBUG "html#html_of_type_expr_list"; + let s = Odoc_info.string_of_type_list sep l in + print_DEBUG "html#html_of_type_expr_list: 1"; + let s2 = Str.global_replace (Str.regexp "\n") "<br> " s in + print_DEBUG "html#html_of_type_expr_list: 2"; + "<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" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) + 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" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type mtyp)) + 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" + (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ctyp)) + in + self#output_code in_title file s + + + (** Return html code for a value. *) + method html_of_value v = + Odoc_info.reset_type_names (); + "<pre>"^(self#keyword "val")^" "^ + (* html mark *) + "<a name=\""^(Naming.value_target v)^"\"></a>"^ + (match v.val_code with + None -> Name.simple v.val_name + | Some c -> + let file = Naming.file_code_value_complete_target v in + self#output_code v.val_name (Filename.concat !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple v.val_name)^"</a>" + )^" : "^ + (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 + self#html_of_parameter_list (Name.father v.val_name) v.val_parameters + else + self#html_of_described_parameter_list (Name.father v.val_name) v.val_parameters + ) + + (** Return html code for an exception. *) + method html_of_exception e = + Odoc_info.reset_type_names (); + "<pre>"^(self#keyword "exception")^" "^ + (* html mark *) + "<a name=\""^(Naming.exception_target e)^"\"></a>"^ + (Name.simple e.ex_name)^ + (match e.ex_args with + [] -> "" + | _ -> + " "^(self#keyword "of")^" "^ + (self#html_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args) + )^ + (match e.ex_alias with + None -> "" + | Some ea -> " = "^ + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> "<a href=\""^(Naming.complete_exception_target e)^"\">"^e.ex_name^"</a>" + ) + )^ + "</pre>\n"^ + (self#html_of_info e.ex_info) + + (** Return html code for a type. *) + method html_of_type t = + Odoc_info.reset_type_names (); + let father = Name.father t.ty_name in + "<br><code>"^(self#keyword "type")^" "^ + (* html mark *) + "<a name=\""^(Naming.type_target t)^"\"></a>"^ + (match t.ty_parameters with + [] -> "" + | tp :: [] -> (self#html_of_type_expr father tp)^" " + | l -> "("^(self#html_of_type_expr_list father ", " l)^") " + )^ + (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 + Type_abstract -> "</code>" + | Type_variant l -> + "=<br>"^ + "</code><table border=\"0\" cellpadding=\"1\">\n"^ + (String.concat "\n" + (List.map + (fun constr -> + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^ + (self#keyword "|")^ + "</code></td>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^ + (self#constructor constr.vc_name)^ + (match constr.vc_args with + [] -> "" + | l -> + " "^(self#keyword "of")^" "^ + (self#html_of_type_expr_list father " * " l) + )^ + "</code></td>\n"^ + (match constr.vc_text with + None -> "" + | Some t -> + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + "(*"^ + "</code></td>"^ + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + (self#html_of_text t)^ + "</code></td>"^ + "<td align=\"left\" valign=\"bottom\" >"^ + "<code>"^ + "*)"^ + "</code></td>" + )^ + "\n</tr>" + ) + l + ) + )^ + "</table>\n" + + | Type_record l -> + "= {<br>"^ + "</code><table border=\"0\" cellpadding=\"1\">\n"^ + (String.concat "\n" + (List.map + (fun r -> + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code> </code>"^ + "</td>\n"^ + "<td align=\"left\" valign=\"top\" >\n"^ + "<code>"^(if r.rf_mutable then self#keyword "mutable " else "")^ + r.rf_name^" : "^(self#html_of_type_expr father r.rf_type)^";"^ + "</code></td>\n"^ + (match r.rf_text with + None -> "" + | Some t -> + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + "(*"^ + "</code></td>"^ + "<td align=\"left\" valign=\"top\" >"^ + "<code>"^ + (self#html_of_text t)^ + "</code></td>"^ + "<td align=\"left\" valign=\"bottom\" >"^ + "<code>"^ + "*)"^ + "</code></td>" + )^ + "\n</tr>" + ) + l + ) + )^ + "</table>\n"^ + "}\n" + )^"\n"^ + (self#html_of_info t.ty_info)^ + "<br>\n" + + (** Return html code for a class attribute. *) + method html_of_attribute a = + let module_name = Name.father (Name.father a.att_value.val_name) in + "<pre>"^(self#keyword "val")^" "^ + (* html mark *) + "<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 + None -> Name.simple a.att_value.val_name + | Some c -> + let file = Naming.file_code_attribute_complete_target a in + self#output_code a.att_value.val_name (Filename.concat !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple a.att_value.val_name)^"</a>" + )^" : "^ + (self#html_of_type_expr module_name a.att_value.val_type)^"</pre>"^ + (self#html_of_info a.att_value.val_info) + + (** Return html code for a class method. *) + method html_of_method m = + let module_name = Name.father (Name.father m.met_value.val_name) in + "<pre>"^(self#keyword "method")^" "^ + (* html mark *) + "<a name=\""^(Naming.method_target m)^"\"></a>"^ + (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 + None -> Name.simple m.met_value.val_name + | Some c -> + let file = Naming.file_code_method_complete_target m in + self#output_code m.met_value.val_name (Filename.concat !Odoc_args.target_dir file) c; + "<a href=\""^file^"\">"^(Name.simple m.met_value.val_name)^"</a>" + )^" : "^ + (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 + self#html_of_parameter_list module_name m.met_value.val_parameters + else + self#html_of_described_parameter_list module_name m.met_value.val_parameters + ) + + (** 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. *) + match Parameter.desc_by_name p name with + None -> "" + | Some t -> self#html_of_text t + ) + | l -> + (* A list of names, we display those with a description. *) + let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in + String.concat "<br>\n" + (List.map + (fun n -> + match Parameter.desc_by_name p n with + None -> "" + | Some t -> "<code>"^n^"</code> : "^(self#html_of_text t) + ) + l2 + ) + + (** Return html code for a list of parameters. *) + method html_of_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + "<div class=\"info\">"^ + "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^ + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^ + "<td>\n"^ + "<table border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^ + (String.concat "" + (List.map + (fun p -> + "<tr>\n"^ + "<td align=\"center\" valign=\"top\" width=\"15%\">\n"^ + "<code>"^ + (match Parameter.complete_name p with + "" -> "?" + | s -> s + )^"</code></td>\n"^ + "<td align=\"center\" valign=\"top\">:</td>\n"^ + "<td>"^(self#html_of_type_expr m_name (Parameter.typ p))^"<br>\n"^ + (self#html_of_parameter_description p)^"\n"^ + "</tr>\n" + ) + l + ) + )^"</table>\n"^ + "</td>\n"^ + "</tr>\n"^ + "</table></div>\n" + + (** 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 + (fun p -> + List.exists + (fun n -> (Parameter.desc_by_name p n) <> None) + (Parameter.names p)) + l + in + let f p = + "<div class=\"info\"><code>"^(Parameter.complete_name p)^"</code> : "^ + (self#html_of_parameter_description p)^"</div>\n" + in + match l2 with + [] -> "" + | _ -> "<br>"^(String.concat "" (List.map f l2)) + + (** Return html code for a list of module parameters. *) + method html_of_module_parameter_list m_name l = + match l with + [] -> + "" + | _ -> + "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n"^ + "<tr>\n"^ + "<td align=\"left\" valign=\"top\" width=\"1%\"><b>"^Odoc_messages.parameters^": </b></td>\n"^ + "<td>\n"^ + "<table border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^ + (String.concat "" + (List.map + (fun (p, desc_opt) -> + "<tr>\n"^ + "<td align=\"center\" valign=\"top\" width=\"15%\">\n"^ + "<code>"^p.mp_name^"</code></td>\n"^ + "<td align=\"center\" valign=\"top\">:</td>\n"^ + "<td>"^(self#html_of_module_type m_name p.mp_type)^"\n"^ + (match desc_opt with + None -> "" + | Some t -> "<br>"^(self#html_of_text t))^ + "\n"^ + "</tr>\n" + ) + l + ) + )^"</table>\n"^ + "</td>\n"^ + "</tr>\n"^ + "</table>\n" + + (** Return html code for a [module_kind]. *) + method html_of_module_kind ?(with_def_syntax=true) k = + match k with + Module_alias m_alias -> + (match m_alias.ma_module with + None -> + (if with_def_syntax then " = " else "")^ + m_alias.ma_name + | Some (Mod m) -> + let (html_file,_) = Naming.html_files m.m_name in + (if with_def_syntax then " = " else "")^ + "<a href=\""^html_file^"\">"^m.m_name^"</a>" + | Some (Modtype mt) -> + let (html_file,_) = Naming.html_files mt.mt_name in + (if with_def_syntax then " : " else "")^ + "<a href=\""^html_file^"\">"^mt.mt_name^"</a>" + ) + | Module_apply (k1, k2) -> + (if with_def_syntax then " = " else "")^ + (self#html_of_module_kind ~with_def_syntax: false k1)^ + " ( "^(self#html_of_module_kind ~with_def_syntax: false k2)^" ) " + + | Module_with (tk, code) -> + (if with_def_syntax then " : " else "")^ + (self#html_of_module_type_kind ~with_def_syntax: false tk)^ + (self#html_of_code ~with_pre: false code) + + | Module_constraint (k, tk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#html_of_module_kind ~with_def_syntax: false k)^" : "^ + (self#html_of_module_type_kind ~with_def_syntax: false tk)^" )" + + | Module_struct _ -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false (Odoc_messages.struct_end^" ")) + + | Module_functor (_, k) -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false "functor ... ")^ + " -> "^(self#html_of_module_kind ~with_def_syntax: false k) + + (** Return html code for a [module_type_kind]. *) + method html_of_module_type_kind ?(with_def_syntax=true) tk = + match tk with + | Module_type_struct _ -> + (if with_def_syntax then " : " else "")^ + (self#html_of_code ~with_pre: false Odoc_messages.sig_end) + + | Module_type_functor (params, k) -> + let f p = "("^p.mp_name^" : "^(self#html_of_module_type "" p.mp_type)^") -> " in + let s1 = String.concat "" (List.map f params) in + let s2 = self#html_of_module_type_kind ~with_def_syntax: false k in + (if with_def_syntax then " : " else "")^s1^s2 + + | Module_type_with (tk2, code) -> + let s = self#html_of_module_type_kind ~with_def_syntax: false tk2 in + (if with_def_syntax then " : " else "")^ + s^(self#html_of_code ~with_pre: false code) + + | Module_type_alias mt_alias -> + (if with_def_syntax then " : " else "")^ + (match mt_alias.mta_module with + None -> + mt_alias.mta_name + | Some mt -> + let (html_file,_) = Naming.html_files mt.mt_name in + "<a href=\""^html_file^"\">"^mt.mt_name^"</a>" + ) + + (** Return html code for a module. *) + method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m = + let (html_file, _) = Naming.html_files m.m_name in + let s1 = + "<pre>"^(self#keyword "module")^" "^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple m.m_name)^"</a>" + else + Name.simple m.m_name + )^ + (self#html_of_module_kind m.m_kind)^ + "</pre>" + in + let s2 = + if info then + (if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info + else + "" + in + s1^s2 + + (** Return html code for a module type. *) + method html_of_modtype ?(info=true) ?(complete=true) ?(with_link=true) mt = + let (html_file, _) = Naming.html_files mt.mt_name in + "<pre>"^(self#keyword "module type")^" "^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple mt.mt_name)^"</a>" + else + Name.simple mt.mt_name + )^ + (match mt.mt_kind with + | Some tk -> self#html_of_module_type_kind tk + | None -> "" + )^ + "</pre>"^ + (if info then + (if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info + else + "" + ) + + (** Return html code for an included module. *) + method html_of_included_module im = + "<pre>"^(self#keyword "include")^" "^ + ( + match im.im_module with + None -> + im.im_name + | Some mmt -> + let (file, name) = + match mmt with + Mod m -> + let (html_file, _) = Naming.html_files m.m_name in + (html_file, m.m_name) + | Modtype mt -> + let (html_file, _) = Naming.html_files mt.mt_name in + (html_file, mt.mt_name) + in + "<a href=\""^file^"\">"^(Name.simple name)^"</a>" + )^ + "</pre>\n" + + (** Return html code for the given [class_kind].*) + method html_of_class_kind father ?(with_def_syntax=true) ckind = + print_DEBUG "html#html_of_class_kind"; + match ckind with + Class_structure _ -> + (if with_def_syntax then " = " else "")^ + (self#html_of_code ~with_pre: false Odoc_messages.object_end) + + | Class_apply capp -> + (if with_def_syntax then " = " else "")^ + ( + match capp.capp_class with + None -> capp.capp_name + | Some cl -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a>" + )^ + " "^ + (String.concat " " + (List.map + (fun s -> self#html_of_code ~with_pre: false ("("^s^")")) + capp.capp_params_code)) + + | Class_constr cco -> + (if with_def_syntax then " = " else "")^ + ( + match cco.cco_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list father ", " l)^"] " + )^ + ( + match cco.cco_class with + None -> cco.cco_name + | Some cl -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a> " + ) + | Class_constraint (ck, ctk) -> + (if with_def_syntax then " = " else "")^ + "( "^(self#html_of_class_kind father ~with_def_syntax: false ck)^ + " : "^ + (self#html_of_class_type_kind father ctk)^ + " )" + + (** Return html code for the given [class_type_kind].*) + method html_of_class_type_kind father ?def_syntax ctkind = + match ctkind with + Class_type cta -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + ( + match cta.cta_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list father ", " l)^"] " + )^ + ( + match cta.cta_class with + None -> + if cta.cta_name = Odoc_messages.object_end then + self#html_of_code ~with_pre: false cta.cta_name + else + cta.cta_name + | Some (Cltype (clt, _)) -> + let (html_file, _) = Naming.html_files clt.clt_name in + "<a href=\""^html_file^"\">"^clt.clt_name^"</a>" + | Some (Cl cl) -> + let (html_file, _) = Naming.html_files cl.cl_name in + "<a href=\""^html_file^"\">"^cl.cl_name^"</a>" + ) + | Class_signature _ -> + (match def_syntax with + None -> "" + | Some s -> " "^s^" ")^ + (self#html_of_code ~with_pre: false Odoc_messages.object_end) + + (** Return html code for a class. *) + method html_of_class ?(complete=true) ?(with_link=true) c = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files c.cl_name in + "<pre>"^(self#keyword "class")^" "^ + (* we add a html tag, the same as for a type so we can + go directly here when the class name is used as a type name *) + "<a name=\""^(Naming.type_target + { ty_name = c.cl_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc })^ + "\"></a>"^ + (print_DEBUG "html#html_of_class : virtual or not" ; "")^ + (if c.cl_virtual then (self#keyword "virtual")^" " else "")^ + ( + match c.cl_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list (Name.father c.cl_name) ", " l)^"] " + )^ + (print_DEBUG "html#html_of_class : with link or not" ; "")^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple c.cl_name)^"</a>" + else + Name.simple c.cl_name + )^ + (match c.cl_parameters with [] -> "" | _ -> " ... ")^ + (print_DEBUG "html#html_of_class : class kind" ; "")^ + (self#html_of_class_kind (Name.father c.cl_name) c.cl_kind)^ + "</pre>"^ + (print_DEBUG "html#html_of_class : info" ; "")^ + ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info) + + (** Return html code for a class type. *) + method html_of_class_type ?(complete=true) ?(with_link=true) ct = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files ct.clt_name in + "<pre>"^(self#keyword "class type")^" "^ + (* we add a html tag, the same as for a type so we can + go directly here when the class type name is used as a type name *) + "<a name=\""^(Naming.type_target + { ty_name = ct.clt_name ; + ty_info = None ; ty_parameters = [] ; + ty_kind = Type_abstract ; ty_manifest = None ; + ty_loc = Odoc_info.dummy_loc })^ + "\"></a>"^ + (if ct.clt_virtual then (self#keyword "virtual")^" " else "")^ + ( + match ct.clt_type_parameters with + [] -> "" + | l -> "["^(self#html_of_type_expr_list (Name.father ct.clt_name) ", " l)^"] " + )^ + ( + if with_link then + "<a href=\""^html_file^"\">"^(Name.simple ct.clt_name)^"</a>" + else + Name.simple ct.clt_name + )^ + (self#html_of_class_type_kind (Name.father ct.clt_name) ~def_syntax: ":" ct.clt_kind)^ + "</pre>"^ + ((if complete then self#html_of_info else self#html_of_info_first_sentence) ct.clt_info) + + (** Return html code to represent a dag, represented as in Odoc_dag2html. *) + method html_of_dag dag = + let f n = + let (name, cct_opt) = n.Odoc_dag2html.valu in + (* if we have a c_opt = Some class then we take its information + because we are sure the name is complete. *) + let (name2, html_file) = + match cct_opt with + None -> (name, fst (Naming.html_files name)) + | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name)) + | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name)) + in + let new_v = + "<table border=1>\n<tr><td>"^ + "<a href=\""^html_file^"\">"^name2^"</a>"^ + "</td></tr>\n</table>\n" + in + { n with Odoc_dag2html.valu = new_v } + in + let a = Array.map f dag.Odoc_dag2html.dag in + Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a } + + (** Return html code for a module comment.*) + method html_of_module_comment text = + "<br>\n"^(self#html_of_text text)^"<br><br>\n" +(* + (* Add some style if there is no style for the first part of the text. *) + let text2 = + match text with + | (Odoc_info.Raw s) :: q -> (Odoc_info.Title (2, [Odoc_info.Raw s])) :: q + | _ -> text + in + self#html_of_text text2 +*) + + (** Return html code for a class comment.*) + method html_of_class_comment text = + (* Add some style if there is no style for the first part of the text. *) + let text2 = + match text with + | (Odoc_info.Raw s) :: q -> + (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q + | _ -> text + 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 = + match inh.ic_class with + None -> (* we can't make the link. *) + (Odoc_info.Code inh.ic_name) :: + (match inh.ic_text with + None -> [] + | Some t -> (Odoc_info.Raw " ") :: t) + | Some cct -> + (* we can create the link. *) + let real_name = (* even if it should be the same *) + match cct with + Cl c -> c.cl_name + | Cltype (ct, _) -> ct.clt_name + in + let (class_file, _) = Naming.html_files real_name in + (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) :: + (match inh.ic_text with + None -> [] + | Some t -> (Odoc_info.Raw " ") :: t) + in + let text = [ + Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ; + Odoc_info.List (List.map f inher_l) + ] + in + let html = self#html_of_text text in + output_string chanout html + + (** Generate html code for the inherited classes of the given class. *) + method generate_class_inheritance_info chanout cl = + let rec iter_kind k = + match k with + Class_structure ([], _) -> + () + | Class_structure (l, _) -> + self#generate_inheritance_info chanout l + | Class_constraint (k, ct) -> + iter_kind k + | Class_apply _ + | Class_constr _ -> + () + 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 + Class_signature ([], _) -> + () + | Class_signature (l, _) -> + self#generate_inheritance_info chanout l + | Class_type _ -> + () + + (** Generate the code of the html page for the given class.*) + method generate_for_class pre post cl = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files cl.cl_name in + let type_file = Naming.file_type_class_complete_target cl.cl_name in + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir html_file) in + let pre_name = opt (fun c -> c.cl_name) pre in + let post_name = opt (fun c -> c.cl_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, cl.cl_name)) + (self#inner_title cl.cl_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name cl.cl_name)^ + "<center><h1>"^Odoc_messages.clas^" "^ + (if cl.cl_virtual then "virtual " else "")^ + "<a href=\""^type_file^"\">"^cl.cl_name^"</a>"^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_class ~with_link: false cl) + ); + (* parameters *) + output_string chanout (self#html_of_parameter_list (Name.father cl.cl_name) cl.cl_parameters); + (* class inheritance *) + self#generate_class_inheritance_info chanout cl; + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + output_string chanout (self#html_of_attribute a) + | Class_method m -> + output_string chanout (self#html_of_method m) + | Class_comment t -> + output_string chanout (self#html_of_class_comment t) + ) + (Class.class_elements cl); + output_string chanout "</html>"; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + cl.cl_name + (Filename.concat !Odoc_args.target_dir type_file) + cl.cl_type + with + Sys_error s -> + raise (Failure s) + + (** Generate the code of the html page for the given class type.*) + method generate_for_class_type pre post clt = + Odoc_info.reset_type_names (); + let (html_file, _) = Naming.html_files clt.clt_name in + let type_file = Naming.file_type_class_complete_target clt.clt_name in + try + let chanout = open_out (Filename.concat !Odoc_args.target_dir html_file) in + let pre_name = opt (fun ct -> ct.clt_name) pre in + let post_name = opt (fun ct -> ct.clt_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, clt.clt_name)) + (self#inner_title clt.clt_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name clt.clt_name)^ + "<center><h1>"^Odoc_messages.class_type^" "^ + (if clt.clt_virtual then "virtual " else "")^ + "<a href=\""^type_file^"\">"^clt.clt_name^"</a>"^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_class_type ~with_link: false clt) + ); + (* class inheritance *) + self#generate_class_type_inheritance_info chanout clt; + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* the various elements *) + List.iter + (fun element -> + match element with + Class_attribute a -> + output_string chanout (self#html_of_attribute a) + | Class_method m -> + output_string chanout (self#html_of_method m) + | Class_comment t -> + output_string chanout (self#html_of_class_comment t) + ) + (Class.class_type_elements clt); + output_string chanout "</html>"; + close_out chanout; + + (* generate the file with the complete class type *) + self#output_class_type + clt.clt_name + (Filename.concat !Odoc_args.target_dir type_file) + clt.clt_type + with + Sys_error s -> + raise (Failure s) + + (** Generate the html file for the given module type. + @raise Failure if an error occurs.*) + method generate_for_module_type pre post mt = + try + let (html_file, _) = Naming.html_files mt.mt_name in + let type_file = Naming.file_type_module_complete_target mt.mt_name in + let chanout = open_out (Filename.concat !Odoc_args.target_dir html_file) in + let pre_name = opt (fun mt -> mt.mt_name) pre in + let post_name = opt (fun mt -> mt.mt_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, mt.mt_name)) + (self#inner_title mt.mt_name) + )^ + "<body>\n"^ + (self#navbar pre_name post_name mt.mt_name)^ + "<center><h1>"^Odoc_messages.module_type^ + " "^ + (match mt.mt_type with + Some _ -> "<a href=\""^type_file^"\">"^mt.mt_name^"</a>" + | None-> mt.mt_name + )^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_modtype ~with_link: false mt) + ); + (* parameters for functors *) + output_string chanout (self#html_of_module_parameter_list "" (Module.module_type_parameters mt)); + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + output_string chanout (self#html_of_module ~complete: false m) + | Element_module_type mt -> + output_string chanout (self#html_of_modtype ~complete: false mt) + | Element_included_module im -> + output_string chanout (self#html_of_included_module im) + | Element_class c -> + output_string chanout (self#html_of_class ~complete: false c) + | Element_class_type ct -> + output_string chanout (self#html_of_class_type ~complete: false ct) + | Element_value v -> + output_string chanout (self#html_of_value v) + | Element_exception e -> + output_string chanout (self#html_of_exception e) + | Element_type t -> + output_string chanout (self#html_of_type t) + | Element_module_comment text -> + output_string chanout (self#html_of_module_comment text) + ) + (Module.module_type_elements mt); + + output_string chanout "</html>"; + close_out chanout; + + (* generate html files for submodules *) + generate_elements self#generate_for_module (Module.module_type_modules mt); + (* generate html files for module types *) + generate_elements self#generate_for_module_type (Module.module_type_module_types mt); + (* generate html files for classes *) + generate_elements self#generate_for_class (Module.module_type_classes mt); + (* generate html files for class types *) + generate_elements self#generate_for_class_type (Module.module_type_class_types mt); + + (* generate the file with the complete module type *) + ( + match mt.mt_type with + None -> () + | Some mty -> self#output_module_type + mt.mt_name + (Filename.concat !Odoc_args.target_dir type_file) + mty + ) + with + Sys_error s -> + raise (Failure s) + + (** Generate the html file for the given module. + @raise Failure if an error occurs.*) + method generate_for_module pre post modu = + try + Odoc_info.verbose ("Generate for module "^modu.m_name); + let (html_file, _) = Naming.html_files modu.m_name in + let type_file = Naming.file_type_module_complete_target modu.m_name in + let chanout = open_out (Filename.concat !Odoc_args.target_dir html_file) in + let pre_name = opt (fun m -> m.m_name) pre in + let post_name = opt (fun m -> m.m_name) post in + output_string chanout + ("<html>\n"^ + (self#header + ~nav: (Some (pre_name, post_name, modu.m_name)) + (self#inner_title modu.m_name) + ) ^ + "<body>\n"^ + (self#navbar pre_name post_name modu.m_name)^ + "<center><h1>"^(if Module.module_is_functor modu then Odoc_messages.functo else Odoc_messages.modul)^ + " "^ + (match modu.m_type with + Some _ -> "<a href=\""^type_file^"\">"^modu.m_name^"</a>" + | None-> modu.m_name + )^ + "</h1></center>\n"^ + "<br>\n"^ + (self#html_of_module ~with_link: false modu) + ); + (* parameters for functors *) + output_string chanout (self#html_of_module_parameter_list "" (Module.module_parameters modu)); + (* a horizontal line *) + output_string chanout "<hr width=\"100%\">\n"; + (* module elements *) + List.iter + (fun ele -> + print_DEBUG "html#generate_for_module : ele ->"; + match ele with + Element_module m -> + output_string chanout (self#html_of_module ~complete: false m) + | Element_module_type mt -> + output_string chanout (self#html_of_modtype ~complete: false mt) + | Element_included_module im -> + output_string chanout (self#html_of_included_module im) + | Element_class c -> + output_string chanout (self#html_of_class ~complete: false c) + | Element_class_type ct -> + output_string chanout (self#html_of_class_type ~complete: false ct) + | Element_value v -> + output_string chanout (self#html_of_value v) + | Element_exception e -> + output_string chanout (self#html_of_exception e) + | Element_type t -> + output_string chanout (self#html_of_type t) + | Element_module_comment text -> + output_string chanout (self#html_of_module_comment text) + ) + (Module.module_elements modu); + + output_string chanout "</html>"; + close_out chanout; + + (* generate html files for submodules *) + generate_elements self#generate_for_module (Module.module_modules modu); + (* generate html files for module types *) + generate_elements self#generate_for_module_type (Module.module_module_types modu); + (* generate html files for classes *) + generate_elements self#generate_for_class (Module.module_classes modu); + (* generate html files for class types *) + generate_elements self#generate_for_class_type (Module.module_class_types modu); + + (* generate the file with the complete module type *) + ( + match modu.m_type with + None -> () + | Some mty -> self#output_module_type + modu.m_name + (Filename.concat !Odoc_args.target_dir type_file) + mty + ) + with + Sys_error s -> + raise (Failure s) + + (** Generate the [index.html] file corresponding to the given module list. + @raise Failure if an error occurs.*) + method generate_index module_list = + try + let title = match !Odoc_args.title with None -> "" | Some t -> self#escape t in + let index_if_not_empty l url m = + match l with + [] -> "" + | _ -> "<a href=\""^url^"\">"^m^"</a><br>\n" + in + let chanout = open_out (Filename.concat !Odoc_args.target_dir index) in + output_string chanout + ( + "<html>\n"^ + (self#header self#title) ^ + "<body>\n"^ + "<center><h1>"^title^"</h1></center>\n"^ + (index_if_not_empty list_types index_types Odoc_messages.index_of_types)^ + (index_if_not_empty list_exceptions index_exceptions Odoc_messages.index_of_exceptions)^ + (index_if_not_empty list_values index_values Odoc_messages.index_of_values)^ + (index_if_not_empty list_attributes index_attributes Odoc_messages.index_of_attributes)^ + (index_if_not_empty list_methods index_methods Odoc_messages.index_of_methods)^ + (index_if_not_empty list_classes index_classes Odoc_messages.index_of_classes)^ + (index_if_not_empty list_class_types index_class_types Odoc_messages.index_of_class_types)^ + (index_if_not_empty list_modules index_modules Odoc_messages.index_of_modules)^ + (index_if_not_empty list_module_types index_module_types Odoc_messages.index_of_module_types)^ + "<br>\n"^ + "<table border=\"0\">\n"^ + (String.concat "" + (List.map + (fun m -> + let (html, _) = Naming.html_files m.m_name in + "<tr><td><a href=\""^html^"\">"^m.m_name^"</a></td>"^ + "<td>"^(self#html_of_info_first_sentence m.m_info)^"</td></tr>\n") + module_list + ) + )^ + "</table>\n"^ + "</body>\n"^ + "</html>" + ); + close_out chanout + with + Sys_error s -> + raise (Failure s) + + (** Generate the values index in the file [index_values.html]. *) + method generate_values_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_values + (fun v -> v.val_name) + (fun v -> v.val_info) + Naming.complete_value_target + Odoc_messages.index_of_values + index_values + + (** Generate the exceptions index in the file [index_exceptions.html]. *) + method generate_exceptions_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_exceptions + (fun e -> e.ex_name) + (fun e -> e.ex_info) + Naming.complete_exception_target + Odoc_messages.index_of_exceptions + index_exceptions + + (** Generate the types index in the file [index_types.html]. *) + method generate_types_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_types + (fun t -> t.ty_name) + (fun t -> t.ty_info) + Naming.complete_type_target + Odoc_messages.index_of_types + index_types + + (** Generate the attributes index in the file [index_attributes.html]. *) + method generate_attributes_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_attributes + (fun a -> a.att_value.val_name) + (fun a -> a.att_value.val_info) + Naming.complete_attribute_target + Odoc_messages.index_of_attributes + index_attributes + + (** Generate the methods index in the file [index_methods.html]. *) + method generate_methods_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_methods + (fun m -> m.met_value.val_name) + (fun m -> m.met_value.val_info) + Naming.complete_method_target + Odoc_messages.index_of_methods + index_methods + + (** Generate the classes index in the file [index_classes.html]. *) + method generate_classes_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_classes + (fun c -> c.cl_name) + (fun c -> c.cl_info) + (fun c -> fst (Naming.html_files c.cl_name)) + Odoc_messages.index_of_classes + index_classes + + (** Generate the class types index in the file [index_class_types.html]. *) + method generate_class_types_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_class_types + (fun ct -> ct.clt_name) + (fun ct -> ct.clt_info) + (fun ct -> fst (Naming.html_files ct.clt_name)) + Odoc_messages.index_of_class_types + index_class_types + + (** Generate the modules index in the file [index_modules.html]. *) + method generate_modules_index module_list = + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_modules + (fun m -> m.m_name) + (fun m -> m.m_info) + (fun m -> fst (Naming.html_files m.m_name)) + Odoc_messages.index_of_modules + index_modules + + (** Generate the module types index in the file [index_module_types.html]. *) + method generate_module_types_index module_list = + let module_types = Odoc_info.Search.module_types module_list in + generate_elements_index + self#header + self#inner_title + self#html_of_info_first_sentence + list_module_types + (fun mt -> mt.mt_name) + (fun mt -> mt.mt_info) + (fun mt -> fst (Naming.html_files mt.mt_name)) + Odoc_messages.index_of_module_types + index_module_types + + (** Generate all the html files from a module list. The main + file is [index.html]. *) + method generate module_list = + let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in + (* init the style *) + self#init_style ; + (* init the lists of elements *) + list_values <- Odoc_info.Search.values module_list ; + list_exceptions <- Odoc_info.Search.exceptions module_list ; + list_types <- Odoc_info.Search.types module_list ; + list_attributes <- Odoc_info.Search.attributes module_list ; + list_methods <- Odoc_info.Search.methods module_list ; + list_classes <- Odoc_info.Search.classes module_list ; + list_class_types <- Odoc_info.Search.class_types module_list ; + list_modules <- Odoc_info.Search.modules module_list ; + list_module_types <- Odoc_info.Search.module_types module_list ; + + (* prepare the page header *) + self#prepare_header sorted_module_list ; + (* Get the names of all known types. *) + let types = Odoc_info.Search.types module_list in + let type_names = List.map (fun t -> t.ty_name) types in + known_types_names <- type_names ; + (* Get the names of all class and class types. *) + let classes = Odoc_info.Search.classes module_list in + let class_types = Odoc_info.Search.class_types module_list in + let class_names = List.map (fun c -> c.cl_name) classes in + let class_type_names = List.map (fun ct -> ct.clt_name) class_types in + known_classes_names <- class_names @ class_type_names ; + (* Get the names of all known modules and module types. *) + let module_types = Odoc_info.Search.module_types module_list in + let modules = Odoc_info.Search.modules module_list in + let module_type_names = List.map (fun mt -> mt.mt_name) module_types in + let module_names = List.map (fun m -> m.m_name) modules in + known_modules_names <- module_type_names @ module_names ; + (* generate html for each module *) + if not !Odoc_args.index_only then + generate_elements self#generate_for_module sorted_module_list ; + + try + self#generate_index sorted_module_list; + self#generate_values_index sorted_module_list ; + self#generate_exceptions_index sorted_module_list ; + self#generate_types_index sorted_module_list ; + self#generate_attributes_index sorted_module_list ; + self#generate_methods_index sorted_module_list ; + self#generate_classes_index sorted_module_list ; + self#generate_class_types_index sorted_module_list ; + self#generate_modules_index sorted_module_list ; + self#generate_module_types_index sorted_module_list ; + with + Failure s -> + prerr_endline s ; + incr Odoc_info.errors + + initializer + Odoc_ocamlhtml.html_of_comment := + (fun s -> self#html_of_text (Odoc_text.Texter.text_of_string s)) + end + + + |