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

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id: odoc_html.ml 9125 2008-11-10 13:03:55Z guesdon $ *)
  13
  14 (** Generation of html documentation.*)
  15
  16 let print_DEBUG s = print_string s ; print_newline ()
  17
  18 open Odoc_info
  19 open Parameter
  20 open Value
  21 open Type
  22 open Exception
  23 open Class
  24 open Module
  25
  26
  27 (** The functions used for naming files and html marks.*)
  28 module Naming =
  29   struct
  30     (** The prefix for types marks. *)
  31     let mark_type = "TYPE"
  32
  33     (** The prefix for functions marks. *)
  34     let mark_function = "FUN"
  35
  36     (** The prefix for exceptions marks. *)
  37     let mark_exception = "EXCEPTION"
  38
  39     (** The prefix for values marks. *)
  40     let mark_value = "VAL"
  41
  42     (** The prefix for attributes marks. *)
  43     let mark_attribute = "ATT"
  44
  45     (** The prefix for methods marks. *)
  46     let mark_method = "METHOD"
  47
  48     (** The prefix for code files.. *)
  49     let code_prefix = "code_"
  50
  51     (** The prefix for type files.. *)
  52     let type_prefix = "type_"
  53
  54     (** Return the two html files names for the given module or class name.*)
  55     let html_files name =
  56       let html_file = name^".html" in
  57       let html_frame_file = name^"-frame.html" in
  58       (html_file, html_frame_file)
  59
  60     (** Return the target for the given prefix and simple name. *)
  61     let target pref simple_name = pref^simple_name
  62
  63     (** Return the complete link target (file#target) for the given prefix string and complete name.*)
  64     let complete_target pref complete_name =
  65       let simple_name = Name.simple complete_name in
  66       let module_name =
  67         let s = Name.father complete_name in
  68         if s = "" then simple_name else s
  69       in
  70       let (html_file, _) = html_files module_name in
  71       html_file^"#"^(target pref simple_name)
  72
  73     (** Return the link target for the given type. *)
  74     let type_target t = target mark_type (Name.simple t.ty_name)
  75
  76     (** Return the complete link target for the given type. *)
  77     let complete_type_target t = complete_target mark_type t.ty_name
  78
  79     (** Return the link target for the given exception. *)
  80     let exception_target e = target mark_exception (Name.simple e.ex_name)
  81
  82     (** Return the complete link target for the given exception. *)
  83     let complete_exception_target e = complete_target mark_exception e.ex_name
  84
  85     (** Return the link target for the given value. *)
  86     let value_target v = target mark_value (Name.simple v.val_name)
  87
  88     (** Return the given value name where symbols accepted in infix values
  89        are replaced by strings, to avoid clashes with the filesystem.*)
  90     let subst_infix_symbols name =
  91       let len = String.length name in
  92       let buf = Buffer.create len in
  93       let ch c = Buffer.add_char buf c in
  94       let st s = Buffer.add_string buf s in
  95       for i = 0 to len - 1 do
  96         match name.[i] with
  97         | '|' -> st "_pipe_"
  98         | '<' -> st "_lt_"
  99         | '>' -> st "_gt_"
 100         | '@' -> st "_at_"
 101         | '^' -> st "_exp_"
 102         | '&' -> st "_amp_"
 103         | '+' -> st "_plus_"
 104         | '-' -> st "_minus_"
 105         | '*' -> st "_star_"
 106         | '/' -> st "_slash_"
 107         | '$' -> st "_dollar_"
 108         | '%' -> st "_percent_"
 109         | '=' -> st "_equal_"
 110         | ':' -> st "_column_"
 111         | '~' -> st "_tilde_"
 112         | '!' -> st "_bang_"
 113         | '?' -> st "_questionmark_"
 114         | c -> ch c
 115       done;
 116       Buffer.contents buf
 117
 118     (** Return the complete link target for the given value. *)
 119     let complete_value_target v = complete_target mark_value v.val_name
 120
 121     (** Return the complete filename for the code of the given value. *)
 122     let file_code_value_complete_target v =
 123       let f = code_prefix^mark_value^(subst_infix_symbols v.val_name)^".html" in
 124       f
 125
 126     (** Return the link target for the given attribute. *)
 127     let attribute_target a = target mark_attribute (Name.simple a.att_value.val_name)
 128
 129     (** Return the complete link target for the given attribute. *)
 130     let complete_attribute_target a = complete_target mark_attribute a.att_value.val_name
 131
 132     (** Return the complete filename for the code of the given attribute. *)
 133     let file_code_attribute_complete_target a =
 134       let f = code_prefix^mark_attribute^a.att_value.val_name^".html" in
 135       f
 136
 137     (** Return the link target for the given method. *)
 138     let method_target m = target mark_method (Name.simple m.met_value.val_name)
 139
 140     (** Return the complete link target for the given method. *)
 141     let complete_method_target m = complete_target mark_method m.met_value.val_name
 142
 143     (** Return the complete filename for the code of the given method. *)
 144     let file_code_method_complete_target m =
 145       let f = code_prefix^mark_method^m.met_value.val_name^".html" in
 146       f
 147
 148     (** Return the link target for the given label section. *)
 149     let label_target l = target "" l
 150
 151     (** Return the complete link target for the given section label. *)
 152     let complete_label_target l = complete_target "" l
 153
 154     (** Return the complete filename for the code of the type of the
 155        given module or module type name. *)
 156     let file_type_module_complete_target name =
 157       let f = type_prefix^name^".html" in
 158       f
 159
 160     (** Return the complete filename for the code of the
 161        given module name. *)
 162     let file_code_module_complete_target name =
 163       let f = code_prefix^name^".html" in
 164       f
 165
 166     (** Return the complete filename for the code of the type of the
 167        given class or class type name. *)
 168     let file_type_class_complete_target name =
 169       let f = type_prefix^name^".html" in
 170       f
 171   end
 172
 173 module StringSet = Set.Make (struct type t = string let compare = compare end)
 174
 175 (** A class with a method to colorize a string which represents OCaml code. *)
 176 class ocaml_code =
 177   object(self)
 178     method html_of_code b ?(with_pre=true) code =
 179       Odoc_ocamlhtml.html_of_code b ~with_pre: with_pre code
 180   end
 181
 182 let new_buf () = Buffer.create 1024
 183 let bp = Printf.bprintf
 184 let bs = Buffer.add_string
 185
 186
 187 (** Generation of html code from text structures. *)
 188 class virtual text =
 189   object (self)
 190     (** We want to display colorized code. *)
 191     inherit ocaml_code
 192
 193     (** Escape the strings which would clash with html syntax, and
 194        make some replacements (double newlines replaced by <br>). *)
 195     method escape s = Odoc_ocamlhtml.escape_base s
 196
 197     method keep_alpha_num s =
 198       let len = String.length s in
 199       let buf = Buffer.create len in
 200       for i = 0 to len - 1 do
 201         match s.[i] with
 202           'a'..'z' | 'A'..'Z' | '0'..'9' -> Buffer.add_char buf s.[i]
 203         | _ -> ()
 204       done;
 205       Buffer.contents buf
 206
 207     (** Return a label created from the first sentence of a text. *)
 208     method label_of_text t=
 209       let t2 = Odoc_info.first_sentence_of_text t in
 210       let s = Odoc_info.string_of_text t2 in
 211       let s2 = self#keep_alpha_num s in
 212       s2
 213
 214     (** Create a label for the associated title.
 215        Return the label specified by the user or a label created
 216        from the title level and the first sentence of the title. *)
 217     method create_title_label (n,label_opt,t) =
 218       match label_opt with
 219         Some s -> s
 220       | None -> Printf.sprintf "%d_%s" n (self#label_of_text t)
 221
 222     (** Print the html code corresponding to the [text] parameter. *)
 223     method html_of_text b t =
 224       List.iter (self#html_of_text_element b) t
 225
 226     (** Print the html code for the [text_element] in parameter. *)
 227     method html_of_text_element b te =
 228       print_DEBUG "text::html_of_text_element";
 229       match te with
 230       | Odoc_info.Raw s -> self#html_of_Raw b s
 231       | Odoc_info.Code s -> self#html_of_Code b s
 232       | Odoc_info.CodePre s -> self#html_of_CodePre b s
 233       | Odoc_info.Verbatim s -> self#html_of_Verbatim b s
 234       | Odoc_info.Bold t -> self#html_of_Bold b t
 235       | Odoc_info.Italic t -> self#html_of_Italic b t
 236       | Odoc_info.Emphasize t -> self#html_of_Emphasize b t
 237       | Odoc_info.Center t -> self#html_of_Center b t
 238       | Odoc_info.Left t -> self#html_of_Left b t
 239       | Odoc_info.Right t -> self#html_of_Right b t
 240       | Odoc_info.List tl -> self#html_of_List b tl
 241       | Odoc_info.Enum tl -> self#html_of_Enum b tl
 242       | Odoc_info.Newline -> self#html_of_Newline b
 243       | Odoc_info.Block t -> self#html_of_Block b t
 244       | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title b n l_opt t
 245       | Odoc_info.Latex s -> self#html_of_Latex b s
 246       | Odoc_info.Link (s, t) -> self#html_of_Link b s t
 247       | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref b name ref_opt
 248       | Odoc_info.Superscript t -> self#html_of_Superscript b t
 249       | Odoc_info.Subscript t -> self#html_of_Subscript b t
 250       | Odoc_info.Module_list l -> self#html_of_Module_list b l
 251       | Odoc_info.Index_list -> self#html_of_Index_list b
 252       | Odoc_info.Custom (s,t) -> self#html_of_custom_text b s t
 253
 254     method html_of_custom_text b s t = ()
 255
 256     method html_of_Raw b s = bs b (self#escape s)
 257
 258     method html_of_Code b s =
 259       if !Args.colorize_code then
 260         self#html_of_code b ~with_pre: false s
 261       else
 262         (
 263          bs b "<code class=\"";
 264          bs b Odoc_ocamlhtml.code_class ;
 265          bs b "\">";
 266          bs b (self#escape s);
 267          bs b "</code>"
 268         )
 269
 270     method html_of_CodePre =
 271         let remove_useless_newlines s =
 272           let len = String.length s in
 273           let rec iter_first n =
 274             if n >= len then
 275               None
 276             else
 277               match s.[n] with
 278               | '\n' -> iter_first (n+1)
 279               | _ -> Some n
 280           in
 281           match iter_first 0 with
 282             None -> ""
 283           | Some first ->
 284               let rec iter_last n =
 285                 if n <= first then
 286                   None
 287                 else
 288                   match s.[n] with
 289                     '\t'  -> iter_last (n-1)
 290                   | _ -> Some n
 291               in
 292               match iter_last (len-1) with
 293                 None -> String.sub s first 1
 294               | Some last -> String.sub s first ((last-first)+1)
 295         in
 296         fun b s ->
 297       if !Args.colorize_code then
 298         (
 299          bs b "<pre></pre>";
 300          self#html_of_code b (remove_useless_newlines s);
 301          bs b "<pre></pre>"
 302         )
 303       else
 304         (
 305          bs b "<pre><code class=\"";
 306          bs b Odoc_ocamlhtml.code_class;
 307          bs b "\">" ;
 308          bs b (self#escape (remove_useless_newlines s));
 309          bs b "</code></pre>"
 310         )
 311
 312     method html_of_Verbatim b s =
 313       bs b "<pre>";
 314       bs b (self#escape s);
 315       bs b "</pre>"
 316
 317     method html_of_Bold b t =
 318       bs b "<b>";
 319       self#html_of_text b t;
 320       bs b "</b>"
 321
 322     method html_of_Italic b t =
 323       bs b "<i>" ;
 324       self#html_of_text b t;
 325       bs b "</i>"
 326
 327     method html_of_Emphasize b t =
 328       bs b "<em>" ;
 329       self#html_of_text b t ;
 330       bs b "</em>"
 331
 332     method html_of_Center b t =
 333       bs b "<center>";
 334       self#html_of_text b t;
 335       bs b "</center>"
 336
 337     method html_of_Left b t =
 338       bs b "<div align=left>";
 339       self#html_of_text b t;
 340       bs b "</div>"
 341
 342     method html_of_Right b t =
 343       bs b "<div align=right>";
 344       self#html_of_text b t;
 345       bs b "</div>"
 346
 347     method html_of_List b tl =
 348       bs b "<ul>\n";
 349       List.iter
 350         (fun t -> bs b "<li>"; self#html_of_text b t; bs b "</li>\n")
 351         tl;
 352       bs b "</ul>\n"
 353
 354     method html_of_Enum b tl =
 355       bs b "<OL>\n";
 356       List.iter
 357         (fun t -> bs b "<li>"; self#html_of_text b t; bs b"</li>\n")
 358         tl;
 359       bs b "</OL>\n"
 360
 361     method html_of_Newline b = bs b "\n<p>\n"
 362
 363     method html_of_Block b t =
 364       bs b "<blockquote>\n";
 365       self#html_of_text b t;
 366       bs b "</blockquote>\n"
 367
 368     method html_of_Title b n label_opt t =
 369       let label1 = self#create_title_label (n, label_opt, t) in
 370       bs b "<a name=\"";
 371       bs b (Naming.label_target label1);
 372       bs b "\"></a>\n";
 373       let (tag_o, tag_c) =
 374         if n > 6 then
 375           (Printf.sprintf "div class=\"h%d\"" n, "div")
 376         else
 377           let t = Printf.sprintf "h%d" n in (t, t)
 378       in
 379       bs b "<";
 380       bs b tag_o;
 381       bs b ">";
 382       self#html_of_text b t;
 383       bs b "</";
 384       bs b tag_c;
 385       bs b ">"
 386
 387     method html_of_Latex b _ = ()
 388       (* don't care about LaTeX stuff in HTML. *)
 389
 390     method html_of_Link b s t =
 391       bs b "<a href=\"";
 392       bs b s ;
 393       bs b "\">";
 394       self#html_of_text b t;
 395       bs b "</a>"
 396
 397     method html_of_Ref b name ref_opt =
 398       match ref_opt with
 399         None ->
 400           self#html_of_text_element b (Odoc_info.Code name)
 401       | Some kind ->
 402           let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in
 403           let (target, text) =
 404             match kind with
 405               Odoc_info.RK_module
 406             | Odoc_info.RK_module_type
 407             | Odoc_info.RK_class
 408             | Odoc_info.RK_class_type ->
 409                 let (html_file, _) = Naming.html_files name in
 410                 (html_file, h name)
 411             | Odoc_info.RK_value -> (Naming.complete_target Naming.mark_value name, h name)
 412             | Odoc_info.RK_type -> (Naming.complete_target Naming.mark_type name, h name)
 413             | Odoc_info.RK_exception -> (Naming.complete_target Naming.mark_exception name, h name)
 414             | Odoc_info.RK_attribute -> (Naming.complete_target Naming.mark_attribute name, h name)
 415             | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name)
 416             | Odoc_info.RK_section t -> (Naming.complete_label_target name,
 417                                          Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
 418           in
 419           bs b ("<a href=\""^target^"\">");
 420           self#html_of_text_element b text;
 421           bs b "</a>"
 422
 423     method html_of_Superscript b t =
 424       bs b "<sup class=\"superscript\">";
 425       self#html_of_text b t;
 426       bs b "</sup>"
 427
 428     method html_of_Subscript b t =
 429       bs b "<sub class=\"subscript\">";
 430       self#html_of_text b t;
 431       bs b "</sub>"
 432
 433     method virtual html_of_info_first_sentence : _
 434
 435     method html_of_Module_list b l =
 436       bs b "<br>\n<table class=\"indextable\">\n";
 437       List.iter
 438         (fun name ->
 439           bs b "<tr><td>";
 440           (
 441            try
 442              let m =
 443                List.find (fun m -> m.m_name = name) self#list_modules
 444              in
 445              let (html, _) = Naming.html_files m.m_name in
 446              bp b "<a href=\"%s\">%s</a></td>" html m.m_name;
 447              bs b "<td>";
 448              self#html_of_info_first_sentence b m.m_info;
 449            with
 450              Not_found ->
 451                Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
 452                bp b "%s</td><td>" name
 453           );
 454           bs b "</td></tr>\n"
 455         )
 456         l;
 457       bs b "</table>\n"
 458
 459     method html_of_Index_list b =
 460       let index_if_not_empty l url m =
 461         match l with
 462           [] -> ()
 463         | _ -> bp b "<a href=\"%s\">%s</a><br>\n" url m
 464       in
 465       index_if_not_empty self#list_types self#index_types Odoc_messages.index_of_types;
 466       index_if_not_empty self#list_exceptions self#index_exceptions Odoc_messages.index_of_exceptions;
 467       index_if_not_empty self#list_values self#index_values Odoc_messages.index_of_values;
 468       index_if_not_empty self#list_attributes self#index_attributes Odoc_messages.index_of_attributes;
 469       index_if_not_empty self#list_methods self#index_methods Odoc_messages.index_of_methods;
 470       index_if_not_empty self#list_classes self#index_classes Odoc_messages.index_of_classes;
 471       index_if_not_empty self#list_class_types self#index_class_types Odoc_messages.index_of_class_types;
 472       index_if_not_empty self#list_modules self#index_modules Odoc_messages.index_of_modules;
 473       index_if_not_empty self#list_module_types self#index_module_types Odoc_messages.index_of_module_types
 474
 475     method virtual list_types : Odoc_info.Type.t_type list
 476     method virtual index_types : string
 477     method virtual list_exceptions : Odoc_info.Exception.t_exception list
 478     method virtual index_exceptions : string
 479     method virtual list_values : Odoc_info.Value.t_value list
 480     method virtual index_values : string
 481     method virtual list_attributes : Odoc_info.Value.t_attribute list
 482     method virtual index_attributes : string
 483     method virtual list_methods : Odoc_info.Value.t_method list
 484     method virtual index_methods : string
 485     method virtual list_classes : Odoc_info.Class.t_class list
 486     method virtual index_classes : string
 487     method virtual list_class_types : Odoc_info.Class.t_class_type list
 488     method virtual index_class_types : string
 489     method virtual list_modules : Odoc_info.Module.t_module list
 490     method virtual index_modules : string
 491     method virtual list_module_types : Odoc_info.Module.t_module_type list
 492     method virtual index_module_types : string
 493
 494   end
 495
 496 (** A class used to generate html code for info structures. *)
 497 class virtual info =
 498   object (self)
 499     (** The list of pairs [(tag, f)] where [f] is a function taking
 500        the [text] associated to [tag] and returning html code.
 501        Add a pair here to handle a tag.*)
 502     val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
 503
 504     (** The method used to get html code from a [text]. *)
 505     method virtual html_of_text : Buffer.t -> Odoc_info.text -> unit
 506
 507     (** Print html for an author list. *)
 508     method html_of_author_list b l =
 509       match l with
 510         [] -> ()
 511       | _ ->
 512           bp b "<b>%s:</b> %s<br>\n"
 513             Odoc_messages.authors
 514             (String.concat ", " l)
 515
 516     (** Print html code for the given optional version information.*)
 517     method html_of_version_opt b v_opt =
 518       match v_opt with
 519         None -> ()
 520       | Some v ->
 521            bp b "<b>%s:</b> %s<br>\n" Odoc_messages.version v
 522
 523     (** Print html code for the given optional since information.*)
 524     method html_of_since_opt b s_opt =
 525       match s_opt with
 526         None -> ()
 527       | Some s ->
 528           bp b "<b>%s</b> %s<br>\n" Odoc_messages.since s
 529
 530     (** Print html code for the given list of raised exceptions.*)
 531     method html_of_raised_exceptions b l =
 532       match l with
 533         [] -> ()
 534       | (s, t) :: [] ->
 535           bp b "<b>%s</b> <code>%s</code> "
 536             Odoc_messages.raises
 537             s;
 538           self#html_of_text b t;
 539           bs b "<br>\n"
 540       | _ ->
 541           bp b "<b>%s</b><ul>" Odoc_messages.raises;
 542           List.iter
 543             (fun (ex, desc) ->
 544               bp b "<li><code>%s</code> " ex ;
 545               self#html_of_text b desc;
 546               bs b "</li>\n"
 547             )
 548             l;
 549           bs b "</ul>\n"
 550
 551     (** Print html code for the given "see also" reference. *)
 552     method html_of_see b (see_ref, t)  =
 553       let t_ref =
 554         match see_ref with
 555           Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ]
 556         | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t
 557         | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t
 558       in
 559       self#html_of_text b t_ref
 560
 561     (** Print html code for the given list of "see also" references.*)
 562     method html_of_sees b l =
 563       match l with
 564         [] -> ()
 565       | see :: [] ->
 566           bp b "<b>%s</b> " Odoc_messages.see_also;
 567           self#html_of_see b see;
 568           bs b "<br>\n"
 569       | _ ->
 570           bp b "<b>%s</b><ul>" Odoc_messages.see_also;
 571           List.iter
 572             (fun see ->
 573               bs b "<li>" ;
 574               self#html_of_see b see;
 575               bs b "</li>\n"
 576             )
 577             l;
 578           bs b "</ul>\n"
 579
 580     (** Print html code for the given optional return information.*)
 581     method html_of_return_opt b return_opt =
 582       match return_opt with
 583         None -> ()
 584       | Some s ->
 585           bp b "<b>%s</b> " Odoc_messages.returns;
 586           self#html_of_text b s;
 587           bs b "<br>\n"
 588
 589     (** Print html code for the given list of custom tagged texts. *)
 590     method html_of_custom b l =
 591       List.iter
 592         (fun (tag, text) ->
 593           try
 594             let f = List.assoc tag tag_functions in
 595             Buffer.add_string b (f text)
 596           with
 597             Not_found ->
 598               Odoc_info.warning (Odoc_messages.tag_not_handled tag)
 599         )
 600         l
 601
 602     (** Print html code for a description, except for the [i_params] field.
 603        @param indent can be specified not to use the style of info comments;
 604        default is [true].
 605     *)
 606     method html_of_info ?(indent=true) b info_opt =
 607       match info_opt with
 608         None ->
 609           ()
 610       | Some info ->
 611           let module M = Odoc_info in
 612           if indent then bs b "<div class=\"info\">\n";
 613           (
 614            match info.M.i_deprecated with
 615             None -> ()
 616            | Some d ->
 617                bs b "<span class=\"warning\">";
 618                bs b Odoc_messages.deprecated ;
 619                bs b "</span>" ;
 620                self#html_of_text b d;
 621                bs b "<br>\n"
 622           );
 623           (
 624            match info.M.i_desc with
 625              None -> ()
 626            | Some d when d = [Odoc_info.Raw ""] -> ()
 627            | Some d -> self#html_of_text b d; bs b "<br>\n"
 628           );
 629           self#html_of_author_list b info.M.i_authors;
 630           self#html_of_version_opt b info.M.i_version;
 631           self#html_of_since_opt b info.M.i_since;
 632           self#html_of_raised_exceptions b info.M.i_raised_exceptions;
 633           self#html_of_return_opt b info.M.i_return_value;
 634           self#html_of_sees b info.M.i_sees;
 635           self#html_of_custom b info.M.i_custom;
 636           if indent then bs b "</div>\n"
 637
 638     (** Print html code for the first sentence of a description.
 639        The titles and lists in this first sentence has been removed.*)
 640     method html_of_info_first_sentence b info_opt =
 641       match info_opt with
 642         None -> ()
 643       | Some info ->
 644           let module M = Odoc_info in
 645           let dep = info.M.i_deprecated <> None in
 646           bs b "<div class=\"info\">\n";
 647           if dep then bs b "<font color=\"#CCCCCC\">";
 648           (
 649            match info.M.i_desc with
 650              None -> ()
 651            | Some d when d = [Odoc_info.Raw ""] -> ()
 652            | Some d ->
 653                self#html_of_text b
 654                  (Odoc_info.text_no_title_no_list
 655                     (Odoc_info.first_sentence_of_text d));
 656                bs b "\n"
 657           );
 658           if dep then bs b "</font>";
 659           bs b "</div>\n"
 660
 661   end
 662
 663
 664
 665 let opt = Odoc_info.apply_opt
 666
 667 let print_concat b sep f =
 668   let rec iter = function
 669       [] -> ()
 670     | [c] -> f c
 671     | c :: q ->
 672         f c;
 673         bs b sep;
 674         iter q
 675   in
 676   iter
 677
 678 let newline_to_indented_br s =
 679   let len = String.length s in
 680   let b = Buffer.create len in
 681   for i = 0 to len - 1 do
 682     match s.[i] with
 683       '\n' -> Buffer.add_string b "<br>     "
 684     | c -> Buffer.add_char b c
 685   done;
 686   Buffer.contents b
 687
 688 (** This class is used to create objects which can generate a simple html documentation. *)
 689 class html =
 690   object (self)
 691     inherit text
 692     inherit info
 693
 694     val mutable doctype =
 695       "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"
 696     val mutable character_encoding =
 697       "<meta content=\"text/html; charset=iso-8859-1\" http-equiv=\"Content-Type\">\n"
 698
 699     (** The default style options. *)
 700     val mutable default_style_options =
 701       ["a:visited {color : #416DFF; text-decoration : none; }" ;
 702         "a:link {color : #416DFF; text-decoration : none;}" ;
 703         "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ;
 704         "a:active {color : Red; text-decoration : underline; }" ;
 705         ".keyword { font-weight : bold ; color : Red }" ;
 706         ".keywordsign { color : #C04600 }" ;
 707         ".superscript { font-size : 4 }" ;
 708         ".subscript { font-size : 4 }" ;
 709         ".comment { color : Green }" ;
 710         ".constructor { color : Blue }" ;
 711         ".type { color : #5C6585 }" ;
 712         ".string { color : Maroon }" ;
 713         ".warning { color : Red ; font-weight : bold }" ;
 714         ".info { margin-left : 3em; margin-right : 3em }" ;
 715         ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ;
 716         ".code { color : #465F91 ; }" ;
 717         "h1 { font-size : 20pt ; text-align: center; }" ;
 718
 719         "h2 { font-size : 20pt ; border: 1px solid #000000; "^
 720         "margin-top: 5px; margin-bottom: 2px;"^
 721         "text-align: center; background-color: #90BDFF ;"^
 722         "padding: 2px; }" ;
 723
 724         "h3 { font-size : 20pt ; border: 1px solid #000000; "^
 725         "margin-top: 5px; margin-bottom: 2px;"^
 726         "text-align: center; background-color: #90DDFF ;"^
 727         "padding: 2px; }" ;
 728
 729         "h4 { font-size : 20pt ; border: 1px solid #000000; "^
 730         "margin-top: 5px; margin-bottom: 2px;"^
 731         "text-align: center; background-color: #90EDFF ;"^
 732         "padding: 2px; }" ;
 733
 734         "h5 { font-size : 20pt ; border: 1px solid #000000; "^
 735         "margin-top: 5px; margin-bottom: 2px;"^
 736         "text-align: center; background-color: #90FDFF ;"^
 737         "padding: 2px; }" ;
 738
 739         "h6 { font-size : 20pt ; border: 1px solid #000000; "^
 740         "margin-top: 5px; margin-bottom: 2px;"^
 741         "text-align: center; background-color: #C0FFFF ; "^
 742         "padding: 2px; }" ;
 743
 744         "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
 745         "margin-top: 5px; margin-bottom: 2px;"^
 746         "text-align: center; background-color: #E0FFFF ; "^
 747         "padding: 2px; }" ;
 748
 749         "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
 750         "margin-top: 5px; margin-bottom: 2px;"^
 751         "text-align: center; background-color: #F0FFFF ; "^
 752         "padding: 2px; }" ;
 753
 754         "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
 755         "margin-top: 5px; margin-bottom: 2px;"^
 756         "text-align: center; background-color: #FFFFFF ; "^
 757         "padding: 2px; }" ;
 758
 759         ".typetable { border-style : hidden }" ;
 760         ".indextable { border-style : hidden }" ;
 761         ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
 762         "body { background-color : White }" ;
 763         "tr { background-color : White }" ;
 764         "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ;
 765         "pre { margin-bottom: 4px }" ;
 766
 767         "div.sig_block {margin-left: 2em}" ;
 768       ]
 769
 770     (** The style file for all pages. *)
 771     val mutable style_file = "style.css"
 772
 773     (** The code to import the style. Initialized in [init_style]. *)
 774     val mutable style = ""
 775
 776     (** The known types names.
 777        Used to know if we must create a link to a type
 778        when printing a type. *)
 779     val mutable known_types_names = StringSet.empty
 780
 781     (** The known class and class type names.
 782        Used to know if we must create a link to a class
 783        or class type or not when printing a type. *)
 784     val mutable known_classes_names = StringSet.empty
 785
 786     (** The known modules and module types names.
 787        Used to know if we must create a link to a type or not
 788        when printing a module type. *)
 789     val mutable known_modules_names = StringSet.empty
 790
 791     method index_prefix =
 792       if !Odoc_args.out_file = Odoc_messages.default_out_file then
 793         "index"
 794       else
 795         Filename.basename !Odoc_args.out_file
 796
 797     (** The main file. *)
 798     method index =
 799       let p = self#index_prefix in
 800       Printf.sprintf "%s.html" p
 801
 802     (** The file for the index of values. *)
 803     method index_values = Printf.sprintf "%s_values.html" self#index_prefix
 804     (** The file for the index of types. *)
 805     method index_types = Printf.sprintf "%s_types.html" self#index_prefix
 806     (** The file for the index of exceptions. *)
 807     method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix
 808     (** The file for the index of attributes. *)
 809     method index_attributes = Printf.sprintf "%s_attributes.html" self#index_prefix
 810     (** The file for the index of methods. *)
 811     method index_methods = Printf.sprintf "%s_methods.html" self#index_prefix
 812     (** The file for the index of classes. *)
 813     method index_classes = Printf.sprintf "%s_classes.html" self#index_prefix
 814     (** The file for the index of class types. *)
 815     method index_class_types = Printf.sprintf "%s_class_types.html" self#index_prefix
 816     (** The file for the index of modules. *)
 817     method index_modules = Printf.sprintf "%s_modules.html" self#index_prefix
 818     (** The file for the index of module types. *)
 819     method index_module_types = Printf.sprintf "%s_module_types.html" self#index_prefix
 820
 821
 822     (** The list of attributes. Filled in the [generate] method. *)
 823     val mutable list_attributes = []
 824     method list_attributes = list_attributes
 825     (** The list of methods. Filled in the [generate] method. *)
 826     val mutable list_methods = []
 827     method list_methods = list_methods
 828     (** The list of values. Filled in the [generate] method. *)
 829     val mutable list_values = []
 830     method list_values = list_values
 831     (** The list of exceptions. Filled in the [generate] method. *)
 832     val mutable list_exceptions = []
 833     method list_exceptions = list_exceptions
 834     (** The list of types. Filled in the [generate] method. *)
 835     val mutable list_types = []
 836     method list_types = list_types
 837     (** The list of modules. Filled in the [generate] method. *)
 838     val mutable list_modules = []
 839     method list_modules = list_modules
 840     (** The list of module types. Filled in the [generate] method. *)
 841     val mutable list_module_types = []
 842     method list_module_types = list_module_types
 843     (** The list of classes. Filled in the [generate] method. *)
 844     val mutable list_classes = []
 845     method list_classes = list_classes
 846     (** The list of class types. Filled in the [generate] method. *)
 847     val mutable list_class_types = []
 848     method list_class_types = list_class_types
 849
 850     (** The header of pages. Must be prepared by the [prepare_header] method.*)
 851     val mutable header = fun b -> fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ()
 852
 853     (** Init the style. *)
 854     method init_style =
 855       (match !Args.css_style with
 856         None ->
 857           let default_style = String.concat "\n" default_style_options in
 858           (
 859            try
 860              let file = Filename.concat !Args.target_dir style_file in
 861              if Sys.file_exists file then
 862                Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
 863              else
 864                (
 865                 let chanout = open_out file in
 866                 output_string chanout default_style ;
 867                 flush chanout ;
 868                 close_out chanout;
 869                 Odoc_info.verbose (Odoc_messages.file_generated file)
 870                )
 871            with
 872              Sys_error s ->
 873                prerr_endline s ;
 874                incr Odoc_info.errors ;
 875           )
 876       | Some f ->
 877           style_file <- f
 878       );
 879       style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n"
 880
 881     (** Get the title given by the user *)
 882     method title = match !Args.title with None -> "" | Some t -> self#escape t
 883
 884     (** Get the title given by the user completed with the given subtitle. *)
 885     method inner_title s =
 886       (match self#title with "" -> "" | t -> t^" : ")^
 887       (self#escape s)
 888
 889     (** Get the page header. *)
 890     method print_header b ?nav ?comments title = header b ?nav ?comments title
 891
 892     (** A function to build the header of pages. *)
 893     method prepare_header module_list =
 894       let f b ?(nav=None) ?(comments=[]) t  =
 895         let link_if_not_empty l m url =
 896           match l with
 897             [] -> ()
 898           | _ ->
 899               bp b "<link title=\"%s\" rel=Appendix href=\"%s\">\n" m url
 900         in
 901         bs b "<head>\n";
 902         bs b style;
 903         bs b character_encoding ;
 904         bs b "<link rel=\"Start\" href=\"";
 905         bs b self#index;
 906         bs b "\">\n" ;
 907         (
 908          match nav with
 909            None -> ()
 910          | Some (pre_opt, post_opt, name) ->
 911              (match pre_opt with
 912                None -> ()
 913              | Some name ->
 914                  bp b "<link rel=\"previous\" href=\"%s\">\n"
 915                    (fst (Naming.html_files name));
 916              );
 917              (match post_opt with
 918                None -> ()
 919              | Some name ->
 920                  bp b "<link rel=\"next\" href=\"%s\">\n"
 921                    (fst (Naming.html_files name));
 922              );
 923              (
 924               let father = Name.father name in
 925               let href = if father = "" then self#index else fst (Naming.html_files father) in
 926               bp b "<link rel=\"Up\" href=\"%s\">\n" href
 927              )
 928         );
 929         link_if_not_empty self#list_types Odoc_messages.index_of_types self#index_types;
 930         link_if_not_empty self#list_exceptions Odoc_messages.index_of_exceptions self#index_exceptions;
 931         link_if_not_empty self#list_values Odoc_messages.index_of_values self#index_values;
 932         link_if_not_empty self#list_attributes Odoc_messages.index_of_attributes self#index_attributes;
 933         link_if_not_empty self#list_methods Odoc_messages.index_of_methods self#index_methods;
 934         link_if_not_empty self#list_classes Odoc_messages.index_of_classes self#index_classes;
 935         link_if_not_empty self#list_class_types Odoc_messages.index_of_class_types self#index_class_types;
 936         link_if_not_empty self#list_modules Odoc_messages.index_of_modules self#index_modules;
 937         link_if_not_empty self#list_module_types Odoc_messages.index_of_module_types self#index_module_types;
 938         let print_one m =
 939           let html_file = fst (Naming.html_files m.m_name) in
 940           bp b "<link title=\"%s\" rel=\"Chapter\" href=\"%s\">"
 941             m.m_name html_file
 942         in
 943         print_concat b "\n" print_one module_list;
 944         self#html_sections_links b comments;
 945         bs b "<title>";
 946         bs b t ;
 947         bs b "</title>\n</head>\n"
 948       in
 949       header <- f
 950
 951     (** Build the html code for the link tags in the header, defining section and
 952        subsections for the titles found in the given comments.*)
 953     method html_sections_links b comments =
 954       let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in
 955       let levels =
 956         let rec iter acc l =
 957           match l with
 958             [] -> acc
 959           | (n,_,_) :: q ->
 960               if List.mem n acc
 961               then iter acc q
 962               else iter (n::acc) q
 963         in
 964         iter [] titles
 965       in
 966       let sorted_levels = List.sort compare levels in
 967       let (section_level, subsection_level) =
 968         match sorted_levels with
 969           [] -> (None, None)
 970         | [n] -> (Some n, None)
 971         | n :: m :: _ -> (Some n, Some m)
 972       in
 973       let titles_per_level level_opt =
 974         match level_opt with
 975           None -> []
 976         | Some n -> List.filter (fun (m,_,_) -> m = n) titles
 977       in
 978       let section_titles = titles_per_level section_level in
 979       let subsection_titles = titles_per_level subsection_level in
 980       let print_lines s_rel titles =
 981         List.iter
 982           (fun (n,lopt,t) ->
 983             let s = Odoc_info.string_of_text t in
 984             let label = self#create_title_label (n,lopt,t) in
 985             bp b "<link title=\"%s\" rel=\"%s\" href=\"#%s\">\n" s s_rel label
 986           )
 987           titles
 988       in
 989       print_lines "Section" section_titles ;
 990       print_lines "Subsection" subsection_titles
 991
 992
 993     (** Html code for navigation bar.
 994        @param pre optional name for optional previous module/class
 995        @param post optional name for optional next module/class
 996        @param name name of current module/class *)
 997     method print_navbar b pre post name =
 998       bs b "<div class=\"navbar\">";
 999       (
1000        match pre with
1001          None -> ()
1002        | Some name ->
1003            bp b "<a href=\"%s\">%s</a>\n"
1004              (fst (Naming.html_files name))
1005              Odoc_messages.previous
1006       );
1007       bs b "&nbsp;";
1008       let father = Name.father name in
1009       let href = if father = "" then self#index else fst (Naming.html_files father) in
1010       bp b "<a href=\"%s\">%s</a>\n" href Odoc_messages.up;
1011       bs b "&nbsp;";
1012       (
1013        match post with
1014          None -> ()
1015        | Some name ->
1016            bp b "<a href=\"%s\">%s</a>\n"
1017              (fst (Naming.html_files name))
1018              Odoc_messages.next
1019       );
1020       bs b "</div>\n"
1021
1022     (** Return html code with the given string in the keyword style.*)
1023     method keyword s =
1024       "<span class=\"keyword\">"^s^"</span>"
1025
1026     (** Return html code with the given string in the constructor style. *)
1027     method constructor s = "<span class=\"constructor\">"^s^"</span>"
1028
1029     (** Output the given ocaml code to the given file name. *)
1030     method private output_code in_title file code =
1031       try
1032         let chanout = open_out file in
1033         let b = new_buf () in
1034         bs b "<html>";
1035         self#print_header b (self#inner_title in_title);
1036         bs b"<body>\n";
1037         self#html_of_code b code;
1038         bs b "</body></html>";
1039         Buffer.output_buffer chanout b;
1040         close_out chanout
1041       with
1042         Sys_error s ->
1043           incr Odoc_info.errors ;
1044           prerr_endline s
1045
1046     (** Take a string and return the string where fully qualified
1047        type (or class or class type) idents
1048        have been replaced by links to the type referenced by the ident.*)
1049     method create_fully_qualified_idents_links m_name s =
1050       let f str_t =
1051         let match_s = Str.matched_string str_t in
1052         let rel = Name.get_relative m_name match_s in
1053         let s_final = Odoc_info.apply_if_equal
1054             Odoc_info.use_hidden_modules
1055             match_s
1056             rel
1057         in
1058         if StringSet.mem match_s known_types_names then
1059            "<a href=\""^(Naming.complete_target Naming.mark_type match_s)^"\">"^
1060            s_final^
1061            "</a>"
1062         else
1063           if StringSet.mem match_s known_classes_names then
1064             let (html_file, _) = Naming.html_files match_s in
1065             "<a href=\""^html_file^"\">"^s_final^"</a>"
1066           else
1067             s_final
1068       in
1069       let s2 = Str.global_substitute
1070           (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)")
1071           f
1072           s
1073       in
1074       s2
1075
1076     (** Take a string and return the string where fully qualified module idents
1077        have been replaced by links to the module referenced by the ident.*)
1078     method create_fully_qualified_module_idents_links m_name s =
1079       let f str_t =
1080         let match_s = Str.matched_string str_t in
1081         let rel = Name.get_relative m_name match_s in
1082         let s_final = Odoc_info.apply_if_equal
1083             Odoc_info.use_hidden_modules
1084             match_s
1085             rel
1086         in
1087         if StringSet.mem match_s known_modules_names then
1088           let (html_file, _) = Naming.html_files match_s in
1089           "<a href=\""^html_file^"\">"^s_final^"</a>"
1090         else
1091           s_final
1092       in
1093       let s2 = Str.global_substitute
1094           (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)")
1095           f
1096           s
1097       in
1098       s2
1099
1100     (** Print html code to display a [Types.type_expr]. *)
1101     method html_of_type_expr b m_name t =
1102       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_type_expr t) in
1103       let s2 = newline_to_indented_br s in
1104       bs b "<code class=\"type\">";
1105       bs b (self#create_fully_qualified_idents_links m_name s2);
1106       bs b "</code>"
1107
1108     (** Print html code to display a [Types.type_expr list]. *)
1109     method html_of_type_expr_list ?par b m_name sep l =
1110       print_DEBUG "html#html_of_type_expr_list";
1111       let s = Odoc_info.string_of_type_list ?par sep l in
1112       print_DEBUG "html#html_of_type_expr_list: 1";
1113       let s2 = newline_to_indented_br s in
1114       print_DEBUG "html#html_of_type_expr_list: 2";
1115       bs b "<code class=\"type\">";
1116       bs b (self#create_fully_qualified_idents_links m_name s2);
1117       bs b "</code>"
1118
1119     (** Print html code to display a [Types.type_expr list] as type parameters
1120        of a class of class type. *)
1121     method html_of_class_type_param_expr_list b m_name l =
1122       let s = Odoc_info.string_of_class_type_param_list l in
1123       let s2 = newline_to_indented_br s in
1124       bs b "<code class=\"type\">[";
1125       bs b (self#create_fully_qualified_idents_links m_name s2);
1126       bs b "]</code>"
1127
1128     method html_of_class_parameter_list b father c =
1129       let s = Odoc_info.string_of_class_params c in
1130       let s = Odoc_info.remove_ending_newline s in
1131       let s2 = newline_to_indented_br s in
1132       bs b "<code class=\"type\">";
1133       bs b (self#create_fully_qualified_idents_links father s2);
1134       bs b "</code>"
1135
1136     (** Print html code to display a list of type parameters for the given type.*)
1137     method html_of_type_expr_param_list b m_name t =
1138       let s = Odoc_info.string_of_type_param_list t in
1139       let s2 = newline_to_indented_br s in
1140       bs b "<code class=\"type\">";
1141       bs b (self#create_fully_qualified_idents_links m_name s2);
1142       bs b "</code>"
1143
1144     (** Print html code to display a [Types.module_type]. *)
1145     method html_of_module_type b ?code m_name t =
1146       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ?code t) in
1147       bs b "<code class=\"type\">";
1148       bs b (self#create_fully_qualified_module_idents_links m_name s);
1149       bs b "</code>"
1150
1151     (** Print html code to display the given module kind. *)
1152     method html_of_module_kind b father ?modu kind =
1153       match kind with
1154         Module_struct eles ->
1155           self#html_of_text b [Code "sig"];
1156           (
1157            match modu with
1158              None ->
1159                bs b "<div class=\"sig_block\">";
1160                List.iter (self#html_of_module_element b father) eles;
1161                bs b "</div>"
1162            | Some m ->
1163                let (html_file, _) = Naming.html_files m.m_name in
1164                bp b " <a href=\"%s\">..</a> " html_file
1165           );
1166           self#html_of_text b [Code "end"]
1167       | Module_alias a ->
1168           bs b "<code class=\"type\">";
1169           bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
1170           bs b "</code>"
1171       | Module_functor (p, k) ->
1172           if !Odoc_info.Args.html_short_functors then
1173             bs b " "
1174           else
1175             bs b "<div class=\"sig_block\">";
1176           self#html_of_module_parameter b father p;
1177           (
1178            match k with
1179              Module_functor _ -> ()
1180            | _ when !Odoc_info.Args.html_short_functors ->
1181                bs b ": "
1182            | _ -> ()
1183           );
1184           self#html_of_module_kind b father ?modu k;
1185           if not !Odoc_info.Args.html_short_functors then
1186             bs b "</div>"
1187       | Module_apply (k1, k2) ->
1188           (* TODO: l'application n'est pas correcte dans un .mli.
1189              Que faire ? -> afficher le module_type du typedtree  *)
1190           self#html_of_module_kind b father k1;
1191           self#html_of_text b [Code "("];
1192           self#html_of_module_kind b father k2;
1193           self#html_of_text b [Code ")"]
1194       | Module_with (k, s) ->
1195           (* TODO: à modifier quand Module_with sera plus détaillé *)
1196           self#html_of_module_type_kind b father ?modu k;
1197           bs b "<code class=\"type\"> ";
1198           bs b (self#create_fully_qualified_module_idents_links father s);
1199           bs b "</code>"
1200       | Module_constraint (k, tk) ->
1201           (* TODO: on affiche quoi ? *)
1202           self#html_of_module_kind b father ?modu k
1203
1204     method html_of_module_parameter b father p =
1205       let (s_functor,s_arrow) =
1206         if !Odoc_info.Args.html_short_functors then
1207           "", ""
1208         else
1209           "functor ", "-> "
1210       in
1211       self#html_of_text b
1212         [
1213           Code (s_functor^"(");
1214           Code p.mp_name ;
1215           Code " : ";
1216         ] ;
1217       self#html_of_module_type_kind b father p.mp_kind;
1218       self#html_of_text b [ Code (") "^s_arrow)]
1219
1220     method html_of_module_element b father ele =
1221       match ele with
1222         Element_module m ->
1223           self#html_of_module b ~complete: false m
1224       | Element_module_type mt ->
1225           self#html_of_modtype b ~complete: false mt
1226       | Element_included_module im ->
1227           self#html_of_included_module b im
1228       | Element_class c ->
1229           self#html_of_class b ~complete: false c
1230       | Element_class_type ct ->
1231           self#html_of_class_type b ~complete: false ct
1232       | Element_value v ->
1233           self#html_of_value b v
1234       | Element_exception e ->
1235           self#html_of_exception b e
1236       | Element_type t ->
1237           self#html_of_type b t
1238       | Element_module_comment text ->
1239           self#html_of_module_comment b text
1240
1241     (** Print html code to display the given module type kind. *)
1242     method html_of_module_type_kind b father ?modu ?mt kind =
1243       match kind with
1244         Module_type_struct eles ->
1245           self#html_of_text b [Code "sig"];
1246           (
1247            match mt with
1248              None ->
1249                (
1250                 match modu with
1251                   None ->
1252                     bs b "<div class=\"sig_block\">";
1253                     List.iter (self#html_of_module_element b father) eles;
1254                     bs b "</div>"
1255                 | Some m ->
1256                     let (html_file, _) = Naming.html_files m.m_name in
1257                     bp b " <a href=\"%s\">..</a> " html_file
1258                )
1259            | Some mt ->
1260                let (html_file, _) = Naming.html_files mt.mt_name in
1261                bp b " <a href=\"%s\">..</a> " html_file
1262           );
1263           self#html_of_text b [Code "end"]
1264       | Module_type_functor (p, k) ->
1265           self#html_of_module_parameter b father p;
1266           self#html_of_module_type_kind b father ?modu ?mt k
1267       | Module_type_alias a ->
1268           bs b "<code class=\"type\">";
1269           bs b (self#create_fully_qualified_module_idents_links father a.mta_name);
1270           bs b "</code>"
1271       | Module_type_with (k, s) ->
1272           self#html_of_module_type_kind b father ?modu ?mt k;
1273           bs b "<code class=\"type\"> ";
1274           bs b (self#create_fully_qualified_module_idents_links father s);
1275           bs b "</code>"
1276
1277     (** Print html code to display the type of a module parameter.. *)
1278     method html_of_module_parameter_type b m_name p =
1279       self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type
1280
1281     (** Generate a file containing the module type in the given file name. *)
1282     method output_module_type in_title file mtyp =
1283       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ~complete: true mtyp) in
1284       self#output_code in_title file s
1285
1286     (** Generate a file containing the class type in the given file name. *)
1287     method output_class_type in_title file ctyp =
1288       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_class_type ~complete: true ctyp) in
1289       self#output_code in_title file s
1290
1291     (** Print html code for a value. *)
1292     method html_of_value b v =
1293       Odoc_info.reset_type_names ();
1294       bs b "<pre>";
1295       bs b (self#keyword "val");
1296       bs b " ";
1297       (* html mark *)
1298       bp b "<a name=\"%s\"></a>" (Naming.value_target v);
1299       (
1300        match v.val_code with
1301          None -> bs b (self#escape (Name.simple v.val_name))
1302        | Some c ->
1303            let file = Naming.file_code_value_complete_target v in
1304            self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
1305            bp b "<a href=\"%s\">%s</a>" file (self#escape (Name.simple v.val_name))
1306       );
1307       bs b " : ";
1308       self#html_of_type_expr b (Name.father v.val_name) v.val_type;
1309       bs b "</pre>";
1310       self#html_of_info b v.val_info;
1311       (
1312        if !Args.with_parameter_list then
1313          self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters
1314        else
1315          self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters
1316       )
1317
1318     (** Print html code for an exception. *)
1319     method html_of_exception b e =
1320       Odoc_info.reset_type_names ();
1321       bs b "<pre>";
1322       bs b (self#keyword "exception");
1323       bs b " ";
1324       (* html mark *)
1325       bp b "<a name=\"%s\"></a>%s"
1326         (Naming.exception_target e)
1327         (Name.simple e.ex_name);
1328       (
1329        match e.ex_args with
1330          [] -> ()
1331        | _ ->
1332            bs b (" "^(self#keyword "of")^" ");
1333            self#html_of_type_expr_list
1334              ~par: false b (Name.father e.ex_name) " * " e.ex_args
1335       );
1336       (
1337        match e.ex_alias with
1338          None -> ()
1339        | Some ea ->
1340            bs b " = ";
1341            (
1342             match ea.ea_ex with
1343               None -> bs b ea.ea_name
1344             | Some e ->
1345                 bp b "<a href=\"%s\">%s</a>" (Naming.complete_exception_target e) e.ex_name
1346            )
1347       );
1348       bs b "</pre>\n";
1349       self#html_of_info b e.ex_info
1350
1351     (** Print html code for a type. *)
1352     method html_of_type b t =
1353       Odoc_info.reset_type_names ();
1354       let father = Name.father t.ty_name in
1355       bs b
1356         (match t.ty_manifest, t.ty_kind with
1357           None, Type_abstract -> "<pre>"
1358         | None, Type_variant _
1359         | None, Type_record _ -> "<br><code>"
1360         | Some _, Type_abstract -> "<pre>"
1361         | Some _, Type_variant _
1362         | Some _, Type_record _ -> "<pre>"
1363         );
1364       bs b ((self#keyword "type")^" ");
1365       (* html mark *)
1366       bp b "<a name=\"%s\"></a>" (Naming.type_target t);
1367       self#html_of_type_expr_param_list b father t;
1368       (match t.ty_parameters with [] -> () | _ -> bs b " ");
1369       bs b ((Name.simple t.ty_name)^" ");
1370       let priv = t.ty_private = Asttypes.Private in
1371       (
1372        match t.ty_manifest with
1373          None -> ()
1374        | Some typ ->
1375            bs b "= ";
1376            if priv then bs b "private ";
1377            self#html_of_type_expr b father typ;
1378            bs b " "
1379       );
1380       (match t.ty_kind with
1381         Type_abstract -> bs b "</pre>"
1382       | Type_variant l ->
1383           bs b "= ";
1384           if priv then bs b "private ";
1385           bs b
1386             (
1387              match t.ty_manifest with
1388                None -> "</code>"
1389              | Some _ -> "</pre>"
1390             );
1391           bs b "<table class=\"typetable\">\n";
1392           let print_one constr =
1393             bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
1394             bs b "<code>";
1395             bs b (self#keyword "|");
1396             bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n";
1397             bs b "<code>";
1398             bs b (self#constructor constr.vc_name);
1399             (
1400              match constr.vc_args with
1401                [] -> ()
1402              | l ->
1403                  bs b (" " ^ (self#keyword "of") ^ " ");
1404                  self#html_of_type_expr_list ~par: false b father " * " l;
1405             );
1406             bs b "</code></td>\n";
1407             (
1408              match constr.vc_text with
1409                None -> ()
1410              | Some t ->
1411                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1412                  bs b "<code>";
1413                  bs b "(*";
1414                  bs b "</code></td>";
1415                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1416                  self#html_of_text b t;
1417                  bs b "</td>";
1418                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
1419                  bs b "<code>";
1420                  bs b "*)";
1421                  bs b "</code></td>";
1422             );
1423             bs b "\n</tr>"
1424           in
1425           print_concat b "\n" print_one l;
1426           bs b "</table>\n"
1427
1428       | Type_record l ->
1429           bs b "= ";
1430           if priv then bs b "private " ;
1431           bs b "{";
1432           bs b
1433             (
1434              match t.ty_manifest with
1435                None -> "</code>"
1436              | Some _ -> "</pre>"
1437             );
1438           bs b "<table class=\"typetable\">\n" ;
1439           let print_one r =
1440             bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
1441             bs b "<code>&nbsp;&nbsp;</code>";
1442             bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
1443             bs b "<code>";
1444             if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
1445             bs b (r.rf_name ^ "&nbsp;: ") ;
1446             self#html_of_type_expr b father r.rf_type;
1447             bs b ";</code></td>\n";
1448             (
1449              match r.rf_text with
1450                None -> ()
1451              | Some t ->
1452                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1453                  bs b "<code>";
1454                  bs b "(*";
1455                  bs b "</code></td>";
1456                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1457                  self#html_of_text b t;
1458                  bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
1459                  bs b "<code>*)</code></td>";
1460             );
1461             bs b "\n</tr>"
1462           in
1463           print_concat b "\n" print_one l;
1464           bs b "</table>\n}\n"
1465       );
1466       bs b "\n";
1467       self#html_of_info b t.ty_info;
1468       bs b "\n"
1469
1470     (** Print html code for a class attribute. *)
1471     method html_of_attribute b a =
1472       let module_name = Name.father (Name.father a.att_value.val_name) in
1473       bs b "<pre>" ;
1474       bs b (self#keyword "val");
1475       bs b " ";
1476       (* html mark *)
1477       bp b "<a name=\"%s\"></a>" (Naming.attribute_target a);
1478       (
1479        if a.att_virtual then
1480          bs b ((self#keyword "virtual")^ " ")
1481        else
1482          ()
1483       );
1484       (
1485        if a.att_mutable then
1486          bs b ((self#keyword Odoc_messages.mutab)^ " ")
1487        else
1488          ()
1489       );(
1490        match a.att_value.val_code with
1491          None -> bs b (Name.simple a.att_value.val_name)
1492        | Some c ->
1493            let file = Naming.file_code_attribute_complete_target a in
1494            self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
1495            bp b "<a href=\"%s\">%s</a>" file (Name.simple a.att_value.val_name);
1496       );
1497       bs b " : ";
1498       self#html_of_type_expr b module_name a.att_value.val_type;
1499       bs b "</pre>";
1500       self#html_of_info b a.att_value.val_info
1501
1502     (** Print html code for a class method. *)
1503     method html_of_method b m =
1504       let module_name = Name.father (Name.father m.met_value.val_name) in
1505       bs b "<pre>";
1506       bs b ((self#keyword "method")^" ");
1507       (* html mark *)
1508       bp b "<a name=\"%s\"></a>" (Naming.method_target m);
1509       if m.met_private then bs b ((self#keyword "private")^" ");
1510       if m.met_virtual then bs b ((self#keyword "virtual")^" ");
1511       (
1512        match m.met_value.val_code with
1513          None -> bs b  (Name.simple m.met_value.val_name)
1514        | Some c ->
1515            let file = Naming.file_code_method_complete_target m in
1516            self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
1517            bp b "<a href=\"%s\">%s</a>" file (Name.simple m.met_value.val_name);
1518       );
1519       bs b " : ";
1520       self#html_of_type_expr b module_name m.met_value.val_type;
1521       bs b "</pre>";
1522       self#html_of_info b m.met_value.val_info;
1523       (
1524        if !Args.with_parameter_list then
1525          self#html_of_parameter_list b
1526            module_name m.met_value.val_parameters
1527        else
1528          self#html_of_described_parameter_list b
1529            module_name m.met_value.val_parameters
1530       )
1531
1532     (** Print html code for the description of a function parameter. *)
1533     method html_of_parameter_description b p =
1534       match Parameter.names p with
1535         [] ->
1536           ()
1537       | name :: [] ->
1538           (
1539            (* Only one name, no need for label for the description. *)
1540            match Parameter.desc_by_name p name with
1541              None -> ()
1542            | Some t -> self#html_of_text b t
1543           )
1544       | l ->
1545           (*  A list of names, we display those with a description. *)
1546           let l2 = List.filter
1547               (fun n -> (Parameter.desc_by_name p n) <> None)
1548               l
1549           in
1550           let print_one n =
1551             match Parameter.desc_by_name p n with
1552               None -> ()
1553             | Some t ->
1554                 bs b "<code>";
1555                 bs b n;
1556                 bs b "</code> : ";
1557                 self#html_of_text b t
1558           in
1559           print_concat b "<br>\n" print_one l2
1560
1561     (** Print html code for a list of parameters. *)
1562     method html_of_parameter_list b m_name l =
1563       match l with
1564         [] -> ()
1565       | _ ->
1566           bs b "<div class=\"param_info\">";
1567           bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
1568           bs b "<tr>\n<td align=\"left\" valign=\"top\" width=\"1%\">";
1569           bs b "<b>";
1570           bs b Odoc_messages.parameters;
1571           bs b ": </b></td>\n" ;
1572           bs b "<td>\n<table class=\"paramstable\">\n";
1573           let print_one p =
1574             bs b "<tr>\n<td align=\"center\" valign=\"top\" width=\"15%\" class=\"code\">\n";
1575             bs b
1576               (
1577                match Parameter.complete_name p with
1578                  "" -> "?"
1579                | s -> s
1580               );
1581             bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n";
1582             bs b "<td>";
1583             self#html_of_type_expr b m_name (Parameter.typ p);
1584             bs b "<br>\n";
1585             self#html_of_parameter_description b p;
1586             bs b "\n</tr>\n";
1587           in
1588           List.iter print_one l;
1589           bs b "</table>\n</td>\n</tr>\n</table></div>\n"
1590
1591     (** Print html code for the parameters which have a name and description. *)
1592     method html_of_described_parameter_list b m_name l =
1593       (* get the params which have a name, and at least one name described. *)
1594       let l2 = List.filter
1595           (fun p ->
1596             List.exists
1597               (fun n -> (Parameter.desc_by_name p n) <> None)
1598               (Parameter.names p))
1599           l
1600       in
1601       let f p =
1602         bs b "<div class=\"param_info\"><code class=\"code\">";
1603         bs b (Parameter.complete_name p);
1604         bs b "</code> : " ;
1605         self#html_of_parameter_description b p;
1606         bs b "</div>\n"
1607       in
1608       List.iter f l2
1609
1610     (** Print html code for a list of module parameters. *)
1611     method html_of_module_parameter_list b m_name l =
1612       match l with
1613         [] ->
1614           ()
1615       | _ ->
1616           bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
1617           bs b "<tr>\n";
1618           bs b "<td align=\"left\" valign=\"top\" width=\"1%%\"><b>";
1619           bs b Odoc_messages.parameters ;
1620           bs b ": </b></td>\n<td>\n";
1621           bs b "<table class=\"paramstable\">\n";
1622           List.iter
1623             (fun (p, desc_opt) ->
1624               bs b "<tr>\n";
1625               bs b "<td align=\"center\" valign=\"top\" width=\"15%\">\n<code>" ;
1626               bs b p.mp_name;
1627               bs b "</code></td>\n" ;
1628               bs b "<td align=\"center\" valign=\"top\">:</td>\n";
1629               bs b "<td>" ;
1630               self#html_of_module_parameter_type b m_name p;
1631               bs b "\n";
1632               (
1633                match desc_opt with
1634                  None -> ()
1635                | Some t ->
1636                    bs b "<br>";
1637                    self#html_of_text b t;
1638                    bs b "\n</tr>\n" ;
1639               )
1640             )
1641             l;
1642           bs b "</table>\n</td>\n</tr>\n</table>\n"
1643
1644     (** Print html code for a module. *)
1645     method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
1646       let (html_file, _) = Naming.html_files m.m_name in
1647       let father = Name.father m.m_name in
1648       bs b "<pre>";
1649       bs b ((self#keyword "module")^" ");
1650       (
1651        if with_link then
1652          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name)
1653        else
1654          bs b (Name.simple m.m_name)
1655       );
1656       (
1657        match m.m_kind with
1658          Module_functor _ when !Odoc_info.Args.html_short_functors  ->
1659            ()
1660        | _ -> bs b ": "
1661       );
1662       self#html_of_module_kind b father ~modu: m m.m_kind;
1663       bs b "</pre>";
1664       if info then
1665         (
1666          if complete then
1667            self#html_of_info ~indent: false
1668          else
1669            self#html_of_info_first_sentence
1670         ) b m.m_info
1671       else
1672         ()
1673
1674     (** Print html code for a module type. *)
1675     method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt =
1676       let (html_file, _) = Naming.html_files mt.mt_name in
1677       let father = Name.father mt.mt_name in
1678       bs b "<pre>";
1679       bs b ((self#keyword "module type")^" ");
1680       (
1681        if with_link then
1682          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name)
1683          else
1684          bs b (Name.simple mt.mt_name)
1685       );
1686       (match mt.mt_kind with
1687         None -> ()
1688       | Some k ->
1689           bs b " = ";
1690           self#html_of_module_type_kind b father ~mt k
1691       );
1692       bs b "</pre>";
1693       if info then
1694         (
1695          if complete then
1696            self#html_of_info ~indent: false
1697          else
1698            self#html_of_info_first_sentence
1699         ) b mt.mt_info
1700       else
1701         ()
1702
1703     (** Print html code for an included module. *)
1704     method html_of_included_module b im =
1705       bs b "<pre>";
1706       bs b ((self#keyword "include")^" ");
1707       (
1708        match im.im_module with
1709          None ->
1710            bs b im.im_name
1711        | Some mmt ->
1712            let (file, name) =
1713              match mmt with
1714                Mod m ->
1715                  let (html_file, _) = Naming.html_files m.m_name in
1716                  (html_file, m.m_name)
1717              | Modtype mt ->
1718                  let (html_file, _) = Naming.html_files mt.mt_name in
1719                  (html_file, mt.mt_name)
1720            in
1721            bp b "<a href=\"%s\">%s</a>" file name
1722       );
1723       bs b "</pre>\n";
1724       self#html_of_info b im.im_info
1725
1726     method html_of_class_element b element =
1727       match element with
1728         Class_attribute a ->
1729           self#html_of_attribute b a
1730       | Class_method m ->
1731           self#html_of_method b m
1732       | Class_comment t ->
1733           self#html_of_class_comment b t
1734
1735     method html_of_class_kind b father ?cl kind =
1736       match kind with
1737         Class_structure (inh, eles) ->
1738           self#html_of_text b [Code "object"];
1739           (
1740            match cl with
1741              None ->
1742                bs b "\n";
1743                (
1744                 match inh with
1745                   [] -> ()
1746                 | _ ->
1747                     self#generate_inheritance_info b inh
1748                );
1749                List.iter (self#html_of_class_element b) eles;
1750            | Some cl ->
1751                let (html_file, _) = Naming.html_files cl.cl_name in
1752                bp b " <a href=\"%s\">..</a> " html_file
1753           );
1754           self#html_of_text b [Code "end"]
1755
1756       | Class_apply capp ->
1757           (* TODO: afficher le type final à partir du typedtree *)
1758           self#html_of_text b [Raw "class application not handled yet"]
1759
1760       | Class_constr cco ->
1761           (
1762            match cco.cco_type_parameters with
1763              [] -> ()
1764            | l ->
1765                self#html_of_class_type_param_expr_list b father l;
1766                bs b " "
1767           );
1768           bs b "<code class=\"type\">";
1769           bs b (self#create_fully_qualified_idents_links father cco.cco_name);
1770           bs b "</code>"
1771
1772       | Class_constraint (ck, ctk) ->
1773           self#html_of_text b [Code "( "] ;
1774           self#html_of_class_kind b father ck;
1775           self#html_of_text b [Code " : "] ;
1776           self#html_of_class_type_kind b father ctk;
1777           self#html_of_text b [Code " )"]
1778
1779     method html_of_class_type_kind b father ?ct kind =
1780       match kind with
1781         Class_type cta ->
1782           (
1783            match cta.cta_type_parameters with
1784              [] -> ()
1785            | l ->
1786                self#html_of_class_type_param_expr_list b father l;
1787                bs b " "
1788           );
1789           bs b "<code class=\"type\">";
1790           bs b (self#create_fully_qualified_idents_links father cta.cta_name);
1791           bs b "</code>"
1792
1793       | Class_signature (inh, eles) ->
1794           self#html_of_text b [Code "object"];
1795           (
1796            match ct with
1797              None ->
1798                bs b "\n";
1799                (
1800                 match inh with
1801                   [] -> ()
1802                 | _ -> self#generate_inheritance_info b inh
1803                );
1804                List.iter (self#html_of_class_element b) eles
1805            | Some ct ->
1806                let (html_file, _) = Naming.html_files ct.clt_name in
1807                bp b " <a href=\"%s\">..</a> " html_file
1808           );
1809           self#html_of_text b [Code "end"]
1810
1811     (** Print html code for a class. *)
1812     method html_of_class b ?(complete=true) ?(with_link=true) c =
1813       let father = Name.father c.cl_name in
1814       Odoc_info.reset_type_names ();
1815       let (html_file, _) = Naming.html_files c.cl_name in
1816       bs b "<pre>";
1817       bs b ((self#keyword "class")^" ");
1818       (* we add a html tag, the same as for a type so we can
1819          go directly here when the class name is used as a type name *)
1820       bp b "<a name=\"%s\"></a>"
1821         (Naming.type_target
1822            { ty_name = c.cl_name ;
1823              ty_info = None ; ty_parameters = [] ;
1824              ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
1825              ty_loc = Odoc_info.dummy_loc ;
1826              ty_code = None ;
1827            }
1828         );
1829       print_DEBUG "html#html_of_class : virtual or not" ;
1830       if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
1831       (
1832        match c.cl_type_parameters with
1833          [] -> ()
1834        | l ->
1835            self#html_of_class_type_param_expr_list b father l;
1836            bs b " "
1837       );
1838       print_DEBUG "html#html_of_class : with link or not" ;
1839       (
1840        if with_link then
1841          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name)
1842        else
1843          bs b (Name.simple c.cl_name)
1844       );
1845
1846       bs b " : " ;
1847       self#html_of_class_parameter_list b father c ;
1848       self#html_of_class_kind b father ~cl: c c.cl_kind;
1849       bs b "</pre>" ;
1850       print_DEBUG "html#html_of_class : info" ;
1851       (
1852        if complete then
1853          self#html_of_info ~indent: false
1854        else
1855          self#html_of_info_first_sentence
1856       ) b c.cl_info
1857
1858     (** Print html code for a class type. *)
1859     method html_of_class_type b ?(complete=true) ?(with_link=true) ct =
1860       Odoc_info.reset_type_names ();
1861       let father = Name.father ct.clt_name in
1862       let (html_file, _) = Naming.html_files ct.clt_name in
1863       bs b "<pre>";
1864       bs b ((self#keyword "class type")^" ");
1865       (* we add a html tag, the same as for a type so we can
1866          go directly here when the class type name is used as a type name *)
1867       bp b "<a name=\"%s\"></a>"
1868         (Naming.type_target
1869            { ty_name = ct.clt_name ;
1870              ty_info = None ; ty_parameters = [] ;
1871              ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
1872              ty_loc = Odoc_info.dummy_loc ;
1873              ty_code = None ;
1874            }
1875         );
1876       if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
1877       (
1878        match ct.clt_type_parameters with
1879         [] -> ()
1880       | l ->
1881           self#html_of_class_type_param_expr_list b father l;
1882           bs b " "
1883       );
1884
1885       if with_link then
1886         bp b "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name)
1887       else
1888         bs b (Name.simple ct.clt_name);
1889
1890       bs b " = ";
1891       self#html_of_class_type_kind b father ~ct ct.clt_kind;
1892       bs b "</pre>";
1893       (
1894        if complete then
1895          self#html_of_info ~indent: false
1896        else
1897          self#html_of_info_first_sentence
1898       ) b ct.clt_info
1899
1900     (** Return html code to represent a dag, represented as in Odoc_dag2html. *)
1901     method html_of_dag dag =
1902       let f n =
1903         let (name, cct_opt) = n.Odoc_dag2html.valu in
1904         (* if we have a c_opt = Some class then we take its information
1905            because we are sure the name is complete. *)
1906         let (name2, html_file) =
1907           match cct_opt with
1908             None -> (name, fst (Naming.html_files name))
1909           | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name))
1910           | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name))
1911         in
1912         let new_v =
1913           "<table border=1>\n<tr><td>"^
1914           "<a href=\""^html_file^"\">"^name2^"</a>"^
1915           "</td></tr>\n</table>\n"
1916         in
1917         { n with Odoc_dag2html.valu = new_v }
1918       in
1919       let a = Array.map f dag.Odoc_dag2html.dag in
1920       Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a }
1921
1922     (** Print html code for a module comment.*)
1923     method html_of_module_comment b text =
1924       bs b "<br>\n";
1925       self#html_of_text b text;
1926       bs b "<br>\n"
1927
1928     (** Print html code for a class comment.*)
1929     method html_of_class_comment b text =
1930       (* Add some style if there is no style for the first part of the text. *)
1931       let text2 =
1932         match text with
1933         | (Odoc_info.Raw s) :: q ->
1934             (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q
1935         | _ -> text
1936       in
1937       self#html_of_text b text2
1938
1939     (** Generate html code for the given list of inherited classes.*)
1940     method generate_inheritance_info b inher_l =
1941       let f inh =
1942         match inh.ic_class with
1943           None -> (* we can't make the link. *)
1944             (Odoc_info.Code inh.ic_name) ::
1945             (match inh.ic_text with
1946               None -> []
1947             | Some t -> (Odoc_info.Raw "    ") :: t)
1948         | Some cct ->
1949             (* we can create the link. *)
1950             let real_name = (* even if it should be the same *)
1951               match cct with
1952                 Cl c -> c.cl_name
1953               | Cltype (ct, _) -> ct.clt_name
1954             in
1955             let (class_file, _) = Naming.html_files real_name in
1956             (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) ::
1957             (match inh.ic_text with
1958               None -> []
1959             | Some t -> (Odoc_info.Raw "    ") :: t)
1960       in
1961       let text = [
1962         Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ;
1963         Odoc_info.List (List.map f inher_l)
1964       ]
1965       in
1966       self#html_of_text b text
1967
1968     (** Generate html code for the inherited classes of the given class. *)
1969     method generate_class_inheritance_info b cl =
1970       let rec iter_kind k =
1971         match k with
1972           Class_structure ([], _) ->
1973             ()
1974         | Class_structure (l, _) ->
1975             self#generate_inheritance_info b l
1976         | Class_constraint (k, ct) ->
1977             iter_kind k
1978         | Class_apply _
1979         | Class_constr _ ->
1980             ()
1981       in
1982       iter_kind cl.cl_kind
1983
1984     (** Generate html code for the inherited classes of the given class type. *)
1985     method generate_class_type_inheritance_info b clt =
1986       match clt.clt_kind with
1987         Class_signature ([], _) ->
1988           ()
1989       | Class_signature (l, _) ->
1990           self#generate_inheritance_info b l
1991       | Class_type _ ->
1992           ()
1993
1994     (** A method to create index files. *)
1995     method generate_elements_index :
1996         'a.
1997         'a list ->
1998           ('a -> Odoc_info.Name.t) ->
1999             ('a -> Odoc_info.info option) ->
2000               ('a -> string) -> string -> string -> unit =
2001     fun elements name info target title simple_file ->
2002       try
2003         let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
2004         let b = new_buf () in
2005         bs b "<html>\n";
2006         self#print_header b (self#inner_title title);
2007         bs b "<body>\n<center><h1>";
2008         bs b title;
2009         bs b "</h1></center>\n" ;
2010
2011         let sorted_elements = List.sort
2012             (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
2013             elements
2014         in
2015         let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in
2016         let f_ele e =
2017           let simple_name = Name.simple (name e) in
2018           let father_name = Name.father (name e) in
2019           bp b "<tr><td><a href=\"%s\">%s</a> " (target e) (self#escape simple_name);
2020           if simple_name <> father_name && father_name <> "" then
2021             bp b "[<a href=\"%s\">%s</a>]" (fst (Naming.html_files father_name)) father_name;
2022           bs b "</td>\n<td>";
2023           self#html_of_info_first_sentence b (info e);
2024           bs b "</td></tr>\n";
2025         in
2026         let f_group l =
2027           match l with
2028             [] -> ()
2029           | e :: _ ->
2030               let s =
2031                 match (Char.uppercase (Name.simple (name e)).[0]) with
2032                   'A'..'Z' as c -> String.make 1 c
2033                 | _ -> ""
2034               in
2035               bs b "<tr><td align=\"left\"><br>";
2036               bs b s ;
2037               bs b "</td></tr>\n" ;
2038               List.iter f_ele l
2039         in
2040         bs b "<table>\n";
2041         List.iter f_group groups ;
2042         bs b "</table><br>\n" ;
2043         bs b "</body>\n</html>";
2044         Buffer.output_buffer chanout b;
2045         close_out chanout
2046       with
2047         Sys_error s ->
2048           raise (Failure s)
2049
2050     (** A method to generate a list of module/class files. *)
2051     method generate_elements :
2052         'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit =
2053       fun f_generate l ->
2054         let rec iter pre_opt = function
2055             [] -> ()
2056           | ele :: [] -> f_generate pre_opt None ele
2057           | ele1 :: ele2 :: q ->
2058               f_generate pre_opt (Some ele2) ele1 ;
2059               iter (Some ele1) (ele2 :: q)
2060         in
2061         iter None l
2062
2063     (** Generate the code of the html page for the given class.*)
2064     method generate_for_class pre post cl =
2065       Odoc_info.reset_type_names ();
2066       let (html_file, _) = Naming.html_files cl.cl_name in
2067       let type_file = Naming.file_type_class_complete_target cl.cl_name in
2068       try
2069         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2070         let b = new_buf () in
2071         let pre_name = opt (fun c -> c.cl_name) pre in
2072         let post_name = opt (fun c -> c.cl_name) post in
2073         bs b doctype ;
2074         bs b "<html>\n";
2075         self#print_header b
2076           ~nav: (Some (pre_name, post_name, cl.cl_name))
2077           ~comments: (Class.class_comments cl)
2078           (self#inner_title cl.cl_name);
2079         bs b "<body>\n";
2080         self#print_navbar b pre_name post_name cl.cl_name;
2081         bs b "<center><h1>";
2082         bs b (Odoc_messages.clas^" ");
2083         if cl.cl_virtual then bs b "virtual " ;
2084         bp b "<a href=\"%s\">%s</a>" type_file cl.cl_name;
2085         bs b "</h1></center>\n<br>\n";
2086         self#html_of_class b ~with_link: false cl;
2087         (* parameters *)
2088         self#html_of_described_parameter_list b
2089           (Name.father cl.cl_name) cl.cl_parameters;
2090         (* class inheritance *)
2091         self#generate_class_inheritance_info b cl;
2092         (* a horizontal line *)
2093         bs b "<hr width=\"100%\">\n";
2094         (* the various elements *)
2095         List.iter (self#html_of_class_element b)
2096           (Class.class_elements ~trans:false cl);
2097         bs b "</body></html>";
2098         Buffer.output_buffer chanout b;
2099         close_out chanout;
2100
2101         (* generate the file with the complete class type *)
2102         self#output_class_type
2103           cl.cl_name
2104           (Filename.concat !Args.target_dir type_file)
2105           cl.cl_type
2106       with
2107         Sys_error s ->
2108           raise (Failure s)
2109
2110     (** Generate the code of the html page for the given class type.*)
2111     method generate_for_class_type pre post clt =
2112       Odoc_info.reset_type_names ();
2113       let (html_file, _) = Naming.html_files clt.clt_name in
2114       let type_file = Naming.file_type_class_complete_target clt.clt_name in
2115       try
2116         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2117         let b = new_buf () in
2118         let pre_name = opt (fun ct -> ct.clt_name) pre in
2119         let post_name = opt (fun ct -> ct.clt_name) post in
2120         bs b doctype ;
2121         bs b "<html>\n";
2122         self#print_header b
2123           ~nav: (Some (pre_name, post_name, clt.clt_name))
2124           ~comments: (Class.class_type_comments clt)
2125           (self#inner_title clt.clt_name);
2126
2127         bs b "<body>\n";
2128         self#print_navbar b pre_name post_name clt.clt_name;
2129         bs b "<center><h1>";
2130         bs b (Odoc_messages.class_type^" ");
2131         if clt.clt_virtual then bs b "virtual ";
2132         bp b "<a href=\"%s\">%s</a>" type_file clt.clt_name;
2133         bs b "</h1></center>\n<br>\n";
2134         self#html_of_class_type b ~with_link: false clt;
2135
2136         (* class inheritance *)
2137         self#generate_class_type_inheritance_info b clt;
2138         (* a horizontal line *)
2139         bs b "<hr width=\"100%\">\n";
2140         (* the various elements *)
2141         List.iter (self#html_of_class_element b)
2142           (Class.class_type_elements ~trans: false clt);
2143         bs b "</body></html>";
2144         Buffer.output_buffer chanout b;
2145         close_out chanout;
2146
2147         (* generate the file with the complete class type *)
2148         self#output_class_type
2149           clt.clt_name
2150           (Filename.concat !Args.target_dir type_file)
2151           clt.clt_type
2152       with
2153         Sys_error s ->
2154           raise (Failure s)
2155
2156     (** Generate the html file for the given module type.
2157        @raise Failure if an error occurs.*)
2158     method generate_for_module_type pre post mt =
2159       try
2160         let (html_file, _) = Naming.html_files mt.mt_name in
2161         let type_file = Naming.file_type_module_complete_target mt.mt_name in
2162         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2163         let b = new_buf () in
2164         let pre_name = opt (fun mt -> mt.mt_name) pre in
2165         let post_name = opt (fun mt -> mt.mt_name) post in
2166         bs b doctype ;
2167         bs b "<html>\n";
2168         self#print_header b
2169           ~nav: (Some (pre_name, post_name, mt.mt_name))
2170           ~comments: (Module.module_type_comments mt)
2171           (self#inner_title mt.mt_name);
2172         bs b "<body>\n";
2173         self#print_navbar b pre_name post_name mt.mt_name;
2174         bp b "<center><h1>";
2175         bs b (Odoc_messages.module_type^" ");
2176         (
2177          match mt.mt_type with
2178            Some _ -> bp b "<a href=\"%s\">%s</a>" type_file mt.mt_name
2179          | None-> bs b mt.mt_name
2180         );
2181         bs b "</h1></center>\n<br>\n" ;
2182         self#html_of_modtype b ~with_link: false mt;
2183
2184         (* parameters for functors *)
2185         self#html_of_module_parameter_list b
2186           (Name.father mt.mt_name)
2187           (Module.module_type_parameters mt);
2188         (* a horizontal line *)
2189         bs b "<hr width=\"100%\">\n";
2190         (* module elements *)
2191         List.iter
2192           (self#html_of_module_element b (Name.father mt.mt_name))
2193           (Module.module_type_elements mt);
2194
2195         bs b "</body></html>";
2196         Buffer.output_buffer chanout b;
2197         close_out chanout;
2198
2199         (* generate html files for submodules *)
2200         self#generate_elements self#generate_for_module (Module.module_type_modules mt);
2201         (* generate html files for module types *)
2202         self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt);
2203         (* generate html files for classes *)
2204         self#generate_elements self#generate_for_class (Module.module_type_classes mt);
2205         (* generate html files for class types *)
2206         self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt);
2207
2208         (* generate the file with the complete module type *)
2209         (
2210          match mt.mt_type with
2211            None -> ()
2212          | Some mty ->
2213              self#output_module_type
2214                mt.mt_name
2215                (Filename.concat !Args.target_dir type_file)
2216                mty
2217         )
2218       with
2219         Sys_error s ->
2220           raise (Failure s)
2221
2222     (** Generate the html file for the given module.
2223        @raise Failure if an error occurs.*)
2224     method generate_for_module pre post modu =
2225       try
2226         Odoc_info.verbose ("Generate for module "^modu.m_name);
2227         let (html_file, _) = Naming.html_files modu.m_name in
2228         let type_file = Naming.file_type_module_complete_target modu.m_name in
2229         let code_file = Naming.file_code_module_complete_target modu.m_name in
2230         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2231         let b = new_buf () in
2232         let pre_name = opt (fun m -> m.m_name) pre in
2233         let post_name = opt (fun m -> m.m_name) post in
2234         bs b doctype ;
2235         bs b "<html>\n";
2236         self#print_header b
2237           ~nav: (Some (pre_name, post_name, modu.m_name))
2238           ~comments: (Module.module_comments modu)
2239           (self#inner_title modu.m_name);
2240         bs b "<body>\n" ;
2241         self#print_navbar b pre_name post_name modu.m_name ;
2242         bs b "<center><h1>";
2243         if modu.m_text_only then
2244           bs b modu.m_name
2245         else
2246           (
2247            bs b
2248              (
2249               if Module.module_is_functor modu then
2250                 Odoc_messages.functo
2251               else
2252                 Odoc_messages.modul
2253              );
2254            bp b " <a href=\"%s\">%s</a>" type_file modu.m_name;
2255            (
2256             match modu.m_code with
2257               None -> ()
2258             | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file
2259            )
2260           );
2261         bs b "</h1></center>\n<br>\n";
2262
2263         if not modu.m_text_only then self#html_of_module b ~with_link: false modu;
2264
2265         (* parameters for functors *)
2266         self#html_of_module_parameter_list b
2267           (Name.father modu.m_name)
2268           (Module.module_parameters modu);
2269
2270         (* a horizontal line *)
2271         if not modu.m_text_only then bs b "<hr width=\"100%\">\n";
2272
2273         (* module elements *)
2274         List.iter
2275           (self#html_of_module_element b (Name.father modu.m_name))
2276           (Module.module_elements modu);
2277
2278         bs b "</body></html>";
2279         Buffer.output_buffer chanout b;
2280         close_out chanout;
2281
2282         (* generate html files for submodules *)
2283         self#generate_elements  self#generate_for_module (Module.module_modules modu);
2284         (* generate html files for module types *)
2285         self#generate_elements  self#generate_for_module_type (Module.module_module_types modu);
2286         (* generate html files for classes *)
2287         self#generate_elements  self#generate_for_class (Module.module_classes modu);
2288         (* generate html files for class types *)
2289         self#generate_elements  self#generate_for_class_type (Module.module_class_types modu);
2290
2291         (* generate the file with the complete module type *)
2292         self#output_module_type
2293           modu.m_name
2294           (Filename.concat !Args.target_dir type_file)
2295           modu.m_type;
2296
2297         match modu.m_code with
2298           None -> ()
2299         | Some code ->
2300             self#output_code
2301               modu.m_name
2302               (Filename.concat !Args.target_dir code_file)
2303               code
2304       with
2305         Sys_error s ->
2306           raise (Failure s)
2307
2308     (** Generate the [<index_prefix>.html] file corresponding to the given module list.
2309        @raise Failure if an error occurs.*)
2310     method generate_index module_list =
2311       try
2312         let chanout = open_out (Filename.concat !Args.target_dir self#index) in
2313         let b = new_buf () in
2314         let title = match !Args.title with None -> "" | Some t -> self#escape t in
2315         bs b doctype ;
2316         bs b "<html>\n";
2317         self#print_header b self#title;
2318         bs b "<body>\n";
2319         bs b "<center><h1>";
2320         bs b title;
2321         bs b "</h1></center>\n" ;
2322         let info = Odoc_info.apply_opt
2323             (Odoc_info.info_of_comment_file module_list)
2324             !Odoc_info.Args.intro_file
2325         in
2326         (
2327          match info with
2328            None ->
2329              self#html_of_Index_list b;
2330              bs b "<br/>";
2331              self#html_of_Module_list b
2332                (List.map (fun m -> m.m_name) module_list);
2333              bs b "</body>\n</html>"
2334          | Some i -> self#html_of_info ~indent: false b info
2335         );
2336         Buffer.output_buffer chanout b;
2337         close_out chanout
2338       with
2339         Sys_error s ->
2340           raise (Failure s)
2341
2342     (** Generate the values index in the file [index_values.html]. *)
2343     method generate_values_index module_list =
2344       self#generate_elements_index
2345         self#list_values
2346         (fun v -> v.val_name)
2347         (fun v -> v.val_info)
2348         Naming.complete_value_target
2349         Odoc_messages.index_of_values
2350         self#index_values
2351
2352     (** Generate the exceptions index in the file [index_exceptions.html]. *)
2353     method generate_exceptions_index module_list =
2354       self#generate_elements_index
2355         self#list_exceptions
2356         (fun e -> e.ex_name)
2357         (fun e -> e.ex_info)
2358         Naming.complete_exception_target
2359         Odoc_messages.index_of_exceptions
2360         self#index_exceptions
2361
2362     (** Generate the types index in the file [index_types.html]. *)
2363     method generate_types_index module_list =
2364       self#generate_elements_index
2365         self#list_types
2366         (fun t -> t.ty_name)
2367         (fun t -> t.ty_info)
2368         Naming.complete_type_target
2369         Odoc_messages.index_of_types
2370         self#index_types
2371
2372     (** Generate the attributes index in the file [index_attributes.html]. *)
2373     method generate_attributes_index module_list =
2374       self#generate_elements_index
2375         self#list_attributes
2376         (fun a -> a.att_value.val_name)
2377         (fun a -> a.att_value.val_info)
2378         Naming.complete_attribute_target
2379         Odoc_messages.index_of_attributes
2380         self#index_attributes
2381
2382     (** Generate the methods index in the file [index_methods.html]. *)
2383     method generate_methods_index module_list =
2384       self#generate_elements_index
2385         self#list_methods
2386         (fun m -> m.met_value.val_name)
2387         (fun m -> m.met_value.val_info)
2388         Naming.complete_method_target
2389         Odoc_messages.index_of_methods
2390         self#index_methods
2391
2392     (** Generate the classes index in the file [index_classes.html]. *)
2393     method generate_classes_index module_list =
2394       self#generate_elements_index
2395         self#list_classes
2396         (fun c -> c.cl_name)
2397         (fun c -> c.cl_info)
2398         (fun c -> fst (Naming.html_files c.cl_name))
2399         Odoc_messages.index_of_classes
2400         self#index_classes
2401
2402     (** Generate the class types index in the file [index_class_types.html]. *)
2403     method generate_class_types_index module_list =
2404       self#generate_elements_index
2405         self#list_class_types
2406         (fun ct -> ct.clt_name)
2407         (fun ct -> ct.clt_info)
2408         (fun ct -> fst (Naming.html_files ct.clt_name))
2409         Odoc_messages.index_of_class_types
2410         self#index_class_types
2411
2412     (** Generate the modules index in the file [index_modules.html]. *)
2413     method generate_modules_index module_list =
2414       self#generate_elements_index
2415         self#list_modules
2416         (fun m -> m.m_name)
2417         (fun m -> m.m_info)
2418         (fun m -> fst (Naming.html_files m.m_name))
2419         Odoc_messages.index_of_modules
2420         self#index_modules
2421
2422     (** Generate the module types index in the file [index_module_types.html]. *)
2423     method generate_module_types_index module_list =
2424       self#generate_elements_index
2425         self#list_module_types
2426         (fun mt -> mt.mt_name)
2427         (fun mt -> mt.mt_info)
2428         (fun mt -> fst (Naming.html_files mt.mt_name))
2429         Odoc_messages.index_of_module_types
2430         self#index_module_types
2431
2432     (** Generate all the html files from a module list. The main
2433        file is [<index_prefix>.html]. *)
2434     method generate module_list =
2435       (* init the style *)
2436       self#init_style ;
2437       (* init the lists of elements *)
2438       list_values <- Odoc_info.Search.values module_list ;
2439       list_exceptions <- Odoc_info.Search.exceptions module_list ;
2440       list_types <- Odoc_info.Search.types module_list ;
2441       list_attributes <- Odoc_info.Search.attributes module_list ;
2442       list_methods <- Odoc_info.Search.methods module_list ;
2443       list_classes <- Odoc_info.Search.classes module_list ;
2444       list_class_types <- Odoc_info.Search.class_types module_list ;
2445       list_modules <- Odoc_info.Search.modules module_list ;
2446       list_module_types <- Odoc_info.Search.module_types module_list ;
2447
2448       (* prepare the page header *)
2449       self#prepare_header module_list ;
2450       (* Get the names of all known types. *)
2451       let types = Odoc_info.Search.types module_list in
2452       known_types_names <-
2453         List.fold_left
2454           (fun acc t -> StringSet.add t.ty_name acc)
2455           known_types_names
2456           types ;
2457       (* Get the names of all class and class types. *)
2458       let classes = Odoc_info.Search.classes module_list in
2459       let class_types = Odoc_info.Search.class_types module_list in
2460       known_classes_names <-
2461         List.fold_left
2462           (fun acc c -> StringSet.add c.cl_name acc)
2463           known_classes_names
2464           classes ;
2465       known_classes_names <-
2466         List.fold_left
2467           (fun acc ct -> StringSet.add ct.clt_name acc)
2468           known_classes_names
2469           class_types ;
2470       (* Get the names of all known modules and module types. *)
2471       let module_types = Odoc_info.Search.module_types module_list in
2472       let modules = Odoc_info.Search.modules module_list in
2473       known_modules_names <-
2474         List.fold_left
2475           (fun acc m -> StringSet.add m.m_name acc)
2476           known_modules_names
2477           modules ;
2478       known_modules_names <-
2479         List.fold_left
2480           (fun acc mt -> StringSet.add mt.mt_name acc)
2481           known_modules_names
2482           module_types ;
2483       (* generate html for each module *)
2484       if not !Args.index_only then
2485         self#generate_elements self#generate_for_module module_list ;
2486
2487       try
2488         self#generate_index module_list;
2489         self#generate_values_index module_list ;
2490         self#generate_exceptions_index module_list ;
2491         self#generate_types_index module_list ;
2492         self#generate_attributes_index module_list ;
2493         self#generate_methods_index module_list ;
2494         self#generate_classes_index module_list ;
2495         self#generate_class_types_index module_list ;
2496         self#generate_modules_index module_list ;
2497         self#generate_module_types_index module_list ;
2498       with
2499         Failure s ->
2500           prerr_endline s ;
2501           incr Odoc_info.errors
2502
2503     initializer
2504       Odoc_ocamlhtml.html_of_comment :=
2505         (fun s ->
2506           let b = new_buf () in
2507           self#html_of_text b (Odoc_text.Texter.text_of_string s);
2508           Buffer.contents b
2509         )
2510   end