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$ *)
  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       (
1371        match t.ty_manifest with
1372          None -> ()
1373        | Some typ ->
1374            bs b "= ";
1375            self#html_of_type_expr b father typ;
1376            bs b " "
1377       );
1378       (match t.ty_kind with
1379         Type_abstract -> bs b "</pre>"
1380       | Type_variant (l, priv) ->
1381           bs b "= ";
1382           if priv then bs b "private" ;
1383           bs b
1384             (
1385              match t.ty_manifest with
1386                None -> "</code>"
1387              | Some _ -> "</pre>"
1388             );
1389           bs b "<table class=\"typetable\">\n";
1390           let print_one constr =
1391             bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
1392             bs b "<code>";
1393             bs b (self#keyword "|");
1394             bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n";
1395             bs b "<code>";
1396             bs b (self#constructor constr.vc_name);
1397             (
1398              match constr.vc_args with
1399                [] -> ()
1400              | l ->
1401                  bs b (" " ^ (self#keyword "of") ^ " ");
1402                  self#html_of_type_expr_list ~par: false b father " * " l;
1403             );
1404             bs b "</code></td>\n";
1405             (
1406              match constr.vc_text with
1407                None -> ()
1408              | Some t ->
1409                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1410                  bs b "<code>";
1411                  bs b "(*";
1412                  bs b "</code></td>";
1413                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1414                  self#html_of_text b t;
1415                  bs b "</td>";
1416                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
1417                  bs b "<code>";
1418                  bs b "*)";
1419                  bs b "</code></td>";
1420             );
1421             bs b "\n</tr>"
1422           in
1423           print_concat b "\n" print_one l;
1424           bs b "</table>\n"
1425
1426       | Type_record (l, priv) ->
1427           bs b "= ";
1428           if priv then bs b "private " ;
1429           bs b "{";
1430           bs b
1431             (
1432              match t.ty_manifest with
1433                None -> "</code>"
1434              | Some _ -> "</pre>"
1435             );
1436           bs b "<table class=\"typetable\">\n" ;
1437           let print_one r =
1438             bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
1439             bs b "<code>&nbsp;&nbsp;</code>";
1440             bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
1441             bs b "<code>";
1442             if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
1443             bs b (r.rf_name ^ "&nbsp;: ") ;
1444             self#html_of_type_expr b father r.rf_type;
1445             bs b ";</code></td>\n";
1446             (
1447              match r.rf_text with
1448                None -> ()
1449              | Some t ->
1450                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1451                  bs b "<code>";
1452                  bs b "(*";
1453                  bs b "</code></td>";
1454                  bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
1455                  self#html_of_text b t;
1456                  bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
1457                  bs b "<code>*)</code></td>";
1458             );
1459             bs b "\n</tr>"
1460           in
1461           print_concat b "\n" print_one l;
1462           bs b "</table>\n}\n"
1463       );
1464       bs b "\n";
1465       self#html_of_info b t.ty_info;
1466       bs b "\n"
1467
1468     (** Print html code for a class attribute. *)
1469     method html_of_attribute b a =
1470       let module_name = Name.father (Name.father a.att_value.val_name) in
1471       bs b "<pre>" ;
1472       bs b (self#keyword "val");
1473       bs b " ";
1474       (* html mark *)
1475       bp b "<a name=\"%s\"></a>" (Naming.attribute_target a);
1476       (
1477        if a.att_mutable then
1478          bs b ((self#keyword Odoc_messages.mutab)^ " ")
1479        else
1480          ()
1481       );
1482       (
1483        match a.att_value.val_code with
1484          None -> bs b (Name.simple a.att_value.val_name)
1485        | Some c ->
1486            let file = Naming.file_code_attribute_complete_target a in
1487            self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
1488            bp b "<a href=\"%s\">%s</a>" file (Name.simple a.att_value.val_name);
1489       );
1490       bs b " : ";
1491       self#html_of_type_expr b module_name  a.att_value.val_type;
1492       bs b "</pre>";
1493       self#html_of_info b a.att_value.val_info
1494
1495     (** Print html code for a class method. *)
1496     method html_of_method b m =
1497       let module_name = Name.father (Name.father m.met_value.val_name) in
1498       bs b "<pre>";
1499       bs b ((self#keyword "method")^" ");
1500       (* html mark *)
1501       bp b "<a name=\"%s\"></a>" (Naming.method_target m);
1502       if m.met_private then bs b ((self#keyword "private")^" ");
1503       if m.met_virtual then bs b ((self#keyword "virtual")^" ");
1504       (
1505        match m.met_value.val_code with
1506          None -> bs b  (Name.simple m.met_value.val_name)
1507        | Some c ->
1508            let file = Naming.file_code_method_complete_target m in
1509            self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
1510            bp b "<a href=\"%s\">%s</a>" file (Name.simple m.met_value.val_name);
1511       );
1512       bs b " : ";
1513       self#html_of_type_expr b module_name m.met_value.val_type;
1514       bs b "</pre>";
1515       self#html_of_info b m.met_value.val_info;
1516       (
1517        if !Args.with_parameter_list then
1518          self#html_of_parameter_list b
1519            module_name m.met_value.val_parameters
1520        else
1521          self#html_of_described_parameter_list b
1522            module_name m.met_value.val_parameters
1523       )
1524
1525     (** Print html code for the description of a function parameter. *)
1526     method html_of_parameter_description b p =
1527       match Parameter.names p with
1528         [] ->
1529           ()
1530       | name :: [] ->
1531           (
1532            (* Only one name, no need for label for the description. *)
1533            match Parameter.desc_by_name p name with
1534              None -> ()
1535            | Some t -> self#html_of_text b t
1536           )
1537       | l ->
1538           (*  A list of names, we display those with a description. *)
1539           let l2 = List.filter
1540               (fun n -> (Parameter.desc_by_name p n) <> None)
1541               l
1542           in
1543           let print_one n =
1544             match Parameter.desc_by_name p n with
1545               None -> ()
1546             | Some t ->
1547                 bs b "<code>";
1548                 bs b n;
1549                 bs b "</code> : ";
1550                 self#html_of_text b t
1551           in
1552           print_concat b "<br>\n" print_one l2
1553
1554     (** Print html code for a list of parameters. *)
1555     method html_of_parameter_list b m_name l =
1556       match l with
1557         [] -> ()
1558       | _ ->
1559           bs b "<div class=\"param_info\">";
1560           bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
1561           bs b "<tr>\n<td align=\"left\" valign=\"top\" width=\"1%\">";
1562           bs b "<b>";
1563           bs b Odoc_messages.parameters;
1564           bs b ": </b></td>\n" ;
1565           bs b "<td>\n<table class=\"paramstable\">\n";
1566           let print_one p =
1567             bs b "<tr>\n<td align=\"center\" valign=\"top\" width=\"15%\" class=\"code\">\n";
1568             bs b
1569               (
1570                match Parameter.complete_name p with
1571                  "" -> "?"
1572                | s -> s
1573               );
1574             bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n";
1575             bs b "<td>";
1576             self#html_of_type_expr b m_name (Parameter.typ p);
1577             bs b "<br>\n";
1578             self#html_of_parameter_description b p;
1579             bs b "\n</tr>\n";
1580           in
1581           List.iter print_one l;
1582           bs b "</table>\n</td>\n</tr>\n</table></div>\n"
1583
1584     (** Print html code for the parameters which have a name and description. *)
1585     method html_of_described_parameter_list b m_name l =
1586       (* get the params which have a name, and at least one name described. *)
1587       let l2 = List.filter
1588           (fun p ->
1589             List.exists
1590               (fun n -> (Parameter.desc_by_name p n) <> None)
1591               (Parameter.names p))
1592           l
1593       in
1594       let f p =
1595         bs b "<div class=\"param_info\"><code class=\"code\">";
1596         bs b (Parameter.complete_name p);
1597         bs b "</code> : " ;
1598         self#html_of_parameter_description b p;
1599         bs b "</div>\n"
1600       in
1601       List.iter f l2
1602
1603     (** Print html code for a list of module parameters. *)
1604     method html_of_module_parameter_list b m_name l =
1605       match l with
1606         [] ->
1607           ()
1608       | _ ->
1609           bs b "<table border=\"0\" cellpadding=\"3\" width=\"100%\">\n";
1610           bs b "<tr>\n";
1611           bs b "<td align=\"left\" valign=\"top\" width=\"1%%\"><b>";
1612           bs b Odoc_messages.parameters ;
1613           bs b ": </b></td>\n<td>\n";
1614           bs b "<table class=\"paramstable\">\n";
1615           List.iter
1616             (fun (p, desc_opt) ->
1617               bs b "<tr>\n";
1618               bs b "<td align=\"center\" valign=\"top\" width=\"15%\">\n<code>" ;
1619               bs b p.mp_name;
1620               bs b "</code></td>\n" ;
1621               bs b "<td align=\"center\" valign=\"top\">:</td>\n";
1622               bs b "<td>" ;
1623               self#html_of_module_parameter_type b m_name p;
1624               bs b "\n";
1625               (
1626                match desc_opt with
1627                  None -> ()
1628                | Some t ->
1629                    bs b "<br>";
1630                    self#html_of_text b t;
1631                    bs b "\n</tr>\n" ;
1632               )
1633             )
1634             l;
1635           bs b "</table>\n</td>\n</tr>\n</table>\n"
1636
1637     (** Print html code for a module. *)
1638     method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
1639       let (html_file, _) = Naming.html_files m.m_name in
1640       let father = Name.father m.m_name in
1641       bs b "<pre>";
1642       bs b ((self#keyword "module")^" ");
1643       (
1644        if with_link then
1645          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name)
1646        else
1647          bs b (Name.simple m.m_name)
1648       );
1649       (
1650        match m.m_kind with
1651          Module_functor _ when !Odoc_info.Args.html_short_functors  ->
1652            ()
1653        | _ -> bs b ": "
1654       );
1655       self#html_of_module_kind b father ~modu: m m.m_kind;
1656       bs b "</pre>";
1657       if info then
1658         (
1659          if complete then
1660            self#html_of_info ~indent: false
1661          else
1662            self#html_of_info_first_sentence
1663         ) b m.m_info
1664       else
1665         ()
1666
1667     (** Print html code for a module type. *)
1668     method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt =
1669       let (html_file, _) = Naming.html_files mt.mt_name in
1670       let father = Name.father mt.mt_name in
1671       bs b "<pre>";
1672       bs b ((self#keyword "module type")^" ");
1673       (
1674        if with_link then
1675          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name)
1676          else
1677          bs b (Name.simple mt.mt_name)
1678       );
1679       (match mt.mt_kind with
1680         None -> ()
1681       | Some k ->
1682           bs b " = ";
1683           self#html_of_module_type_kind b father ~mt k
1684       );
1685       bs b "</pre>";
1686       if info then
1687         (
1688          if complete then
1689            self#html_of_info ~indent: false
1690          else
1691            self#html_of_info_first_sentence
1692         ) b mt.mt_info
1693       else
1694         ()
1695
1696     (** Print html code for an included module. *)
1697     method html_of_included_module b im =
1698       bs b "<pre>";
1699       bs b ((self#keyword "include")^" ");
1700       (
1701        match im.im_module with
1702          None ->
1703            bs b im.im_name
1704        | Some mmt ->
1705            let (file, name) =
1706              match mmt with
1707                Mod m ->
1708                  let (html_file, _) = Naming.html_files m.m_name in
1709                  (html_file, m.m_name)
1710              | Modtype mt ->
1711                  let (html_file, _) = Naming.html_files mt.mt_name in
1712                  (html_file, mt.mt_name)
1713            in
1714            bp b "<a href=\"%s\">%s</a>" file name
1715       );
1716       bs b "</pre>\n";
1717       self#html_of_info b im.im_info
1718
1719     method html_of_class_element b element =
1720       match element with
1721         Class_attribute a ->
1722           self#html_of_attribute b a
1723       | Class_method m ->
1724           self#html_of_method b m
1725       | Class_comment t ->
1726           self#html_of_class_comment b t
1727
1728     method html_of_class_kind b father ?cl kind =
1729       match kind with
1730         Class_structure (inh, eles) ->
1731           self#html_of_text b [Code "object"];
1732           (
1733            match cl with
1734              None ->
1735                bs b "\n";
1736                (
1737                 match inh with
1738                   [] -> ()
1739                 | _ ->
1740                     self#generate_inheritance_info b inh
1741                );
1742                List.iter (self#html_of_class_element b) eles;
1743            | Some cl ->
1744                let (html_file, _) = Naming.html_files cl.cl_name in
1745                bp b " <a href=\"%s\">..</a> " html_file
1746           );
1747           self#html_of_text b [Code "end"]
1748
1749       | Class_apply capp ->
1750           (* TODO: afficher le type final à partir du typedtree *)
1751           self#html_of_text b [Raw "class application not handled yet"]
1752
1753       | Class_constr cco ->
1754           (
1755            match cco.cco_type_parameters with
1756              [] -> ()
1757            | l ->
1758                self#html_of_class_type_param_expr_list b father l;
1759                bs b " "
1760           );
1761           bs b "<code class=\"type\">";
1762           bs b (self#create_fully_qualified_idents_links father cco.cco_name);
1763           bs b "</code>"
1764
1765       | Class_constraint (ck, ctk) ->
1766           self#html_of_text b [Code "( "] ;
1767           self#html_of_class_kind b father ck;
1768           self#html_of_text b [Code " : "] ;
1769           self#html_of_class_type_kind b father ctk;
1770           self#html_of_text b [Code " )"]
1771
1772     method html_of_class_type_kind b father ?ct kind =
1773       match kind with
1774         Class_type cta ->
1775           (
1776            match cta.cta_type_parameters with
1777              [] -> ()
1778            | l ->
1779                self#html_of_class_type_param_expr_list b father l;
1780                bs b " "
1781           );
1782           bs b "<code class=\"type\">";
1783           bs b (self#create_fully_qualified_idents_links father cta.cta_name);
1784           bs b "</code>"
1785
1786       | Class_signature (inh, eles) ->
1787           self#html_of_text b [Code "object"];
1788           (
1789            match ct with
1790              None ->
1791                bs b "\n";
1792                (
1793                 match inh with
1794                   [] -> ()
1795                 | _ -> self#generate_inheritance_info b inh
1796                );
1797                List.iter (self#html_of_class_element b) eles
1798            | Some ct ->
1799                let (html_file, _) = Naming.html_files ct.clt_name in
1800                bp b " <a href=\"%s\">..</a> " html_file
1801           );
1802           self#html_of_text b [Code "end"]
1803
1804     (** Print html code for a class. *)
1805     method html_of_class b ?(complete=true) ?(with_link=true) c =
1806       let father = Name.father c.cl_name in
1807       Odoc_info.reset_type_names ();
1808       let (html_file, _) = Naming.html_files c.cl_name in
1809       bs b "<pre>";
1810       bs b ((self#keyword "class")^" ");
1811       (* we add a html tag, the same as for a type so we can
1812          go directly here when the class name is used as a type name *)
1813       bp b "<a name=\"%s\"></a>"
1814         (Naming.type_target
1815            { ty_name = c.cl_name ;
1816              ty_info = None ; ty_parameters = [] ;
1817              ty_kind = Type_abstract ; ty_manifest = None ;
1818              ty_loc = Odoc_info.dummy_loc ;
1819              ty_code = None ;
1820            }
1821         );
1822       print_DEBUG "html#html_of_class : virtual or not" ;
1823       if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
1824       (
1825        match c.cl_type_parameters with
1826          [] -> ()
1827        | l ->
1828            self#html_of_class_type_param_expr_list b father l;
1829            bs b " "
1830       );
1831       print_DEBUG "html#html_of_class : with link or not" ;
1832       (
1833        if with_link then
1834          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple c.cl_name)
1835        else
1836          bs b (Name.simple c.cl_name)
1837       );
1838
1839       bs b " : " ;
1840       self#html_of_class_parameter_list b father c ;
1841       self#html_of_class_kind b father ~cl: c c.cl_kind;
1842       bs b "</pre>" ;
1843       print_DEBUG "html#html_of_class : info" ;
1844       (
1845        if complete then
1846          self#html_of_info ~indent: false
1847        else
1848          self#html_of_info_first_sentence
1849       ) b c.cl_info
1850
1851     (** Print html code for a class type. *)
1852     method html_of_class_type b ?(complete=true) ?(with_link=true) ct =
1853       Odoc_info.reset_type_names ();
1854       let father = Name.father ct.clt_name in
1855       let (html_file, _) = Naming.html_files ct.clt_name in
1856       bs b "<pre>";
1857       bs b ((self#keyword "class type")^" ");
1858       (* we add a html tag, the same as for a type so we can
1859          go directly here when the class type name is used as a type name *)
1860       bp b "<a name=\"%s\"></a>"
1861         (Naming.type_target
1862            { ty_name = ct.clt_name ;
1863              ty_info = None ; ty_parameters = [] ;
1864              ty_kind = Type_abstract ; ty_manifest = None ;
1865              ty_loc = Odoc_info.dummy_loc ;
1866              ty_code = None ;
1867            }
1868         );
1869       if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
1870       (
1871        match ct.clt_type_parameters with
1872         [] -> ()
1873       | l ->
1874           self#html_of_class_type_param_expr_list b father l;
1875           bs b " "
1876       );
1877
1878       if with_link then
1879         bp b "<a href=\"%s\">%s</a>" html_file (Name.simple ct.clt_name)
1880       else
1881         bs b (Name.simple ct.clt_name);
1882
1883       bs b " = ";
1884       self#html_of_class_type_kind b father ~ct ct.clt_kind;
1885       bs b "</pre>";
1886       (
1887        if complete then
1888          self#html_of_info ~indent: false
1889        else
1890          self#html_of_info_first_sentence
1891       ) b ct.clt_info
1892
1893     (** Return html code to represent a dag, represented as in Odoc_dag2html. *)
1894     method html_of_dag dag =
1895       let f n =
1896         let (name, cct_opt) = n.Odoc_dag2html.valu in
1897         (* if we have a c_opt = Some class then we take its information
1898            because we are sure the name is complete. *)
1899         let (name2, html_file) =
1900           match cct_opt with
1901             None -> (name, fst (Naming.html_files name))
1902           | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name))
1903           | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name))
1904         in
1905         let new_v =
1906           "<table border=1>\n<tr><td>"^
1907           "<a href=\""^html_file^"\">"^name2^"</a>"^
1908           "</td></tr>\n</table>\n"
1909         in
1910         { n with Odoc_dag2html.valu = new_v }
1911       in
1912       let a = Array.map f dag.Odoc_dag2html.dag in
1913       Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a }
1914
1915     (** Print html code for a module comment.*)
1916     method html_of_module_comment b text =
1917       bs b "<br>\n";
1918       self#html_of_text b text;
1919       bs b "<br>\n"
1920
1921     (** Print html code for a class comment.*)
1922     method html_of_class_comment b text =
1923       (* Add some style if there is no style for the first part of the text. *)
1924       let text2 =
1925         match text with
1926         | (Odoc_info.Raw s) :: q ->
1927             (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q
1928         | _ -> text
1929       in
1930       self#html_of_text b text2
1931
1932     (** Generate html code for the given list of inherited classes.*)
1933     method generate_inheritance_info b inher_l =
1934       let f inh =
1935         match inh.ic_class with
1936           None -> (* we can't make the link. *)
1937             (Odoc_info.Code inh.ic_name) ::
1938             (match inh.ic_text with
1939               None -> []
1940             | Some t -> (Odoc_info.Raw "    ") :: t)
1941         | Some cct ->
1942             (* we can create the link. *)
1943             let real_name = (* even if it should be the same *)
1944               match cct with
1945                 Cl c -> c.cl_name
1946               | Cltype (ct, _) -> ct.clt_name
1947             in
1948             let (class_file, _) = Naming.html_files real_name in
1949             (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) ::
1950             (match inh.ic_text with
1951               None -> []
1952             | Some t -> (Odoc_info.Raw "    ") :: t)
1953       in
1954       let text = [
1955         Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ;
1956         Odoc_info.List (List.map f inher_l)
1957       ]
1958       in
1959       self#html_of_text b text
1960
1961     (** Generate html code for the inherited classes of the given class. *)
1962     method generate_class_inheritance_info b cl =
1963       let rec iter_kind k =
1964         match k with
1965           Class_structure ([], _) ->
1966             ()
1967         | Class_structure (l, _) ->
1968             self#generate_inheritance_info b l
1969         | Class_constraint (k, ct) ->
1970             iter_kind k
1971         | Class_apply _
1972         | Class_constr _ ->
1973             ()
1974       in
1975       iter_kind cl.cl_kind
1976
1977     (** Generate html code for the inherited classes of the given class type. *)
1978     method generate_class_type_inheritance_info b clt =
1979       match clt.clt_kind with
1980         Class_signature ([], _) ->
1981           ()
1982       | Class_signature (l, _) ->
1983           self#generate_inheritance_info b l
1984       | Class_type _ ->
1985           ()
1986
1987     (** A method to create index files. *)
1988     method generate_elements_index :
1989         'a.
1990         'a list ->
1991           ('a -> Odoc_info.Name.t) ->
1992             ('a -> Odoc_info.info option) ->
1993               ('a -> string) -> string -> string -> unit =
1994     fun elements name info target title simple_file ->
1995       try
1996         let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
1997         let b = new_buf () in
1998         bs b "<html>\n";
1999         self#print_header b (self#inner_title title);
2000         bs b "<body>\n<center><h1>";
2001         bs b title;
2002         bs b "</h1></center>\n" ;
2003
2004         let sorted_elements = List.sort
2005             (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
2006             elements
2007         in
2008         let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in
2009         let f_ele e =
2010           let simple_name = Name.simple (name e) in
2011           let father_name = Name.father (name e) in
2012           bp b "<tr><td><a href=\"%s\">%s</a> " (target e) (self#escape simple_name);
2013           if simple_name <> father_name && father_name <> "" then
2014             bp b "[<a href=\"%s\">%s</a>]" (fst (Naming.html_files father_name)) father_name;
2015           bs b "</td>\n<td>";
2016           self#html_of_info_first_sentence b (info e);
2017           bs b "</td></tr>\n";
2018         in
2019         let f_group l =
2020           match l with
2021             [] -> ()
2022           | e :: _ ->
2023               let s =
2024                 match (Char.uppercase (Name.simple (name e)).[0]) with
2025                   'A'..'Z' as c -> String.make 1 c
2026                 | _ -> ""
2027               in
2028               bs b "<tr><td align=\"left\"><br>";
2029               bs b s ;
2030               bs b "</td></tr>\n" ;
2031               List.iter f_ele l
2032         in
2033         bs b "<table>\n";
2034         List.iter f_group groups ;
2035         bs b "</table><br>\n" ;
2036         bs b "</body>\n</html>";
2037         Buffer.output_buffer chanout b;
2038         close_out chanout
2039       with
2040         Sys_error s ->
2041           raise (Failure s)
2042
2043     (** A method to generate a list of module/class files. *)
2044     method generate_elements :
2045         'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit =
2046       fun f_generate l ->
2047         let rec iter pre_opt = function
2048             [] -> ()
2049           | ele :: [] -> f_generate pre_opt None ele
2050           | ele1 :: ele2 :: q ->
2051               f_generate pre_opt (Some ele2) ele1 ;
2052               iter (Some ele1) (ele2 :: q)
2053         in
2054         iter None l
2055
2056     (** Generate the code of the html page for the given class.*)
2057     method generate_for_class pre post cl =
2058       Odoc_info.reset_type_names ();
2059       let (html_file, _) = Naming.html_files cl.cl_name in
2060       let type_file = Naming.file_type_class_complete_target cl.cl_name in
2061       try
2062         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2063         let b = new_buf () in
2064         let pre_name = opt (fun c -> c.cl_name) pre in
2065         let post_name = opt (fun c -> c.cl_name) post in
2066         bs b doctype ;
2067         bs b "<html>\n";
2068         self#print_header b
2069           ~nav: (Some (pre_name, post_name, cl.cl_name))
2070           ~comments: (Class.class_comments cl)
2071           (self#inner_title cl.cl_name);
2072         bs b "<body>\n";
2073         self#print_navbar b pre_name post_name cl.cl_name;
2074         bs b "<center><h1>";
2075         bs b (Odoc_messages.clas^" ");
2076         if cl.cl_virtual then bs b "virtual " ;
2077         bp b "<a href=\"%s\">%s</a>" type_file cl.cl_name;
2078         bs b "</h1></center>\n<br>\n";
2079         self#html_of_class b ~with_link: false cl;
2080         (* parameters *)
2081         self#html_of_described_parameter_list b
2082           (Name.father cl.cl_name) cl.cl_parameters;
2083         (* class inheritance *)
2084         self#generate_class_inheritance_info b cl;
2085         (* a horizontal line *)
2086         bs b "<hr width=\"100%\">\n";
2087         (* the various elements *)
2088         List.iter (self#html_of_class_element b)
2089           (Class.class_elements ~trans:false cl);
2090         bs b "</body></html>";
2091         Buffer.output_buffer chanout b;
2092         close_out chanout;
2093
2094         (* generate the file with the complete class type *)
2095         self#output_class_type
2096           cl.cl_name
2097           (Filename.concat !Args.target_dir type_file)
2098           cl.cl_type
2099       with
2100         Sys_error s ->
2101           raise (Failure s)
2102
2103     (** Generate the code of the html page for the given class type.*)
2104     method generate_for_class_type pre post clt =
2105       Odoc_info.reset_type_names ();
2106       let (html_file, _) = Naming.html_files clt.clt_name in
2107       let type_file = Naming.file_type_class_complete_target clt.clt_name in
2108       try
2109         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2110         let b = new_buf () in
2111         let pre_name = opt (fun ct -> ct.clt_name) pre in
2112         let post_name = opt (fun ct -> ct.clt_name) post in
2113         bs b doctype ;
2114         bs b "<html>\n";
2115         self#print_header b
2116           ~nav: (Some (pre_name, post_name, clt.clt_name))
2117           ~comments: (Class.class_type_comments clt)
2118           (self#inner_title clt.clt_name);
2119
2120         bs b "<body>\n";
2121         self#print_navbar b pre_name post_name clt.clt_name;
2122         bs b "<center><h1>";
2123         bs b (Odoc_messages.class_type^" ");
2124         if clt.clt_virtual then bs b "virtual ";
2125         bp b "<a href=\"%s\">%s</a>" type_file clt.clt_name;
2126         bs b "</h1></center>\n<br>\n";
2127         self#html_of_class_type b ~with_link: false clt;
2128
2129         (* class inheritance *)
2130         self#generate_class_type_inheritance_info b clt;
2131         (* a horizontal line *)
2132         bs b "<hr width=\"100%\">\n";
2133         (* the various elements *)
2134         List.iter (self#html_of_class_element b)
2135           (Class.class_type_elements ~trans: false clt);
2136         bs b "</body></html>";
2137         Buffer.output_buffer chanout b;
2138         close_out chanout;
2139
2140         (* generate the file with the complete class type *)
2141         self#output_class_type
2142           clt.clt_name
2143           (Filename.concat !Args.target_dir type_file)
2144           clt.clt_type
2145       with
2146         Sys_error s ->
2147           raise (Failure s)
2148
2149     (** Generate the html file for the given module type.
2150        @raise Failure if an error occurs.*)
2151     method generate_for_module_type pre post mt =
2152       try
2153         let (html_file, _) = Naming.html_files mt.mt_name in
2154         let type_file = Naming.file_type_module_complete_target mt.mt_name in
2155         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2156         let b = new_buf () in
2157         let pre_name = opt (fun mt -> mt.mt_name) pre in
2158         let post_name = opt (fun mt -> mt.mt_name) post in
2159         bs b doctype ;
2160         bs b "<html>\n";
2161         self#print_header b
2162           ~nav: (Some (pre_name, post_name, mt.mt_name))
2163           ~comments: (Module.module_type_comments mt)
2164           (self#inner_title mt.mt_name);
2165         bs b "<body>\n";
2166         self#print_navbar b pre_name post_name mt.mt_name;
2167         bp b "<center><h1>";
2168         bs b (Odoc_messages.module_type^" ");
2169         (
2170          match mt.mt_type with
2171            Some _ -> bp b "<a href=\"%s\">%s</a>" type_file mt.mt_name
2172          | None-> bs b mt.mt_name
2173         );
2174         bs b "</h1></center>\n<br>\n" ;
2175         self#html_of_modtype b ~with_link: false mt;
2176
2177         (* parameters for functors *)
2178         self#html_of_module_parameter_list b
2179           (Name.father mt.mt_name)
2180           (Module.module_type_parameters mt);
2181         (* a horizontal line *)
2182         bs b "<hr width=\"100%\">\n";
2183         (* module elements *)
2184         List.iter
2185           (self#html_of_module_element b (Name.father mt.mt_name))
2186           (Module.module_type_elements mt);
2187
2188         bs b "</body></html>";
2189         Buffer.output_buffer chanout b;
2190         close_out chanout;
2191
2192         (* generate html files for submodules *)
2193         self#generate_elements self#generate_for_module (Module.module_type_modules mt);
2194         (* generate html files for module types *)
2195         self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt);
2196         (* generate html files for classes *)
2197         self#generate_elements self#generate_for_class (Module.module_type_classes mt);
2198         (* generate html files for class types *)
2199         self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt);
2200
2201         (* generate the file with the complete module type *)
2202         (
2203          match mt.mt_type with
2204            None -> ()
2205          | Some mty ->
2206              self#output_module_type
2207                mt.mt_name
2208                (Filename.concat !Args.target_dir type_file)
2209                mty
2210         )
2211       with
2212         Sys_error s ->
2213           raise (Failure s)
2214
2215     (** Generate the html file for the given module.
2216        @raise Failure if an error occurs.*)
2217     method generate_for_module pre post modu =
2218       try
2219         Odoc_info.verbose ("Generate for module "^modu.m_name);
2220         let (html_file, _) = Naming.html_files modu.m_name in
2221         let type_file = Naming.file_type_module_complete_target modu.m_name in
2222         let code_file = Naming.file_code_module_complete_target modu.m_name in
2223         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
2224         let b = new_buf () in
2225         let pre_name = opt (fun m -> m.m_name) pre in
2226         let post_name = opt (fun m -> m.m_name) post in
2227         bs b doctype ;
2228         bs b "<html>\n";
2229         self#print_header b
2230           ~nav: (Some (pre_name, post_name, modu.m_name))
2231           ~comments: (Module.module_comments modu)
2232           (self#inner_title modu.m_name);
2233         bs b "<body>\n" ;
2234         self#print_navbar b pre_name post_name modu.m_name ;
2235         bs b "<center><h1>";
2236         if modu.m_text_only then
2237           bs b modu.m_name
2238         else
2239           (
2240            bs b
2241              (
2242               if Module.module_is_functor modu then
2243                 Odoc_messages.functo
2244               else
2245                 Odoc_messages.modul
2246              );
2247            bp b " <a href=\"%s\">%s</a>" type_file modu.m_name;
2248            (
2249             match modu.m_code with
2250               None -> ()
2251             | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file
2252            )
2253           );
2254         bs b "</h1></center>\n<br>\n";
2255
2256         if not modu.m_text_only then self#html_of_module b ~with_link: false modu;
2257
2258         (* parameters for functors *)
2259         self#html_of_module_parameter_list b
2260           (Name.father modu.m_name)
2261           (Module.module_parameters modu);
2262
2263         (* a horizontal line *)
2264         if not modu.m_text_only then bs b "<hr width=\"100%\">\n";
2265
2266         (* module elements *)
2267         List.iter
2268           (self#html_of_module_element b (Name.father modu.m_name))
2269           (Module.module_elements modu);
2270
2271         bs b "</body></html>";
2272         Buffer.output_buffer chanout b;
2273         close_out chanout;
2274
2275         (* generate html files for submodules *)
2276         self#generate_elements  self#generate_for_module (Module.module_modules modu);
2277         (* generate html files for module types *)
2278         self#generate_elements  self#generate_for_module_type (Module.module_module_types modu);
2279         (* generate html files for classes *)
2280         self#generate_elements  self#generate_for_class (Module.module_classes modu);
2281         (* generate html files for class types *)
2282         self#generate_elements  self#generate_for_class_type (Module.module_class_types modu);
2283
2284         (* generate the file with the complete module type *)
2285         self#output_module_type
2286           modu.m_name
2287           (Filename.concat !Args.target_dir type_file)
2288           modu.m_type;
2289
2290         match modu.m_code with
2291           None -> ()
2292         | Some code ->
2293             self#output_code
2294               modu.m_name
2295               (Filename.concat !Args.target_dir code_file)
2296               code
2297       with
2298         Sys_error s ->
2299           raise (Failure s)
2300
2301     (** Generate the [<index_prefix>.html] file corresponding to the given module list.
2302        @raise Failure if an error occurs.*)
2303     method generate_index module_list =
2304       try
2305         let chanout = open_out (Filename.concat !Args.target_dir self#index) in
2306         let b = new_buf () in
2307         let title = match !Args.title with None -> "" | Some t -> self#escape t in
2308         bs b doctype ;
2309         bs b "<html>\n";
2310         self#print_header b self#title;
2311         bs b "<body>\n";
2312         bs b "<center><h1>";
2313         bs b title;
2314         bs b "</h1></center>\n" ;
2315         let info = Odoc_info.apply_opt
2316             (Odoc_info.info_of_comment_file module_list)
2317             !Odoc_info.Args.intro_file
2318         in
2319         (
2320          match info with
2321            None ->
2322              self#html_of_Index_list b;
2323              bs b "<br/>";
2324              self#html_of_Module_list b
2325                (List.map (fun m -> m.m_name) module_list);
2326              bs b "</body>\n</html>"
2327          | Some i -> self#html_of_info ~indent: false b info
2328         );
2329         Buffer.output_buffer chanout b;
2330         close_out chanout
2331       with
2332         Sys_error s ->
2333           raise (Failure s)
2334
2335     (** Generate the values index in the file [index_values.html]. *)
2336     method generate_values_index module_list =
2337       self#generate_elements_index
2338         self#list_values
2339         (fun v -> v.val_name)
2340         (fun v -> v.val_info)
2341         Naming.complete_value_target
2342         Odoc_messages.index_of_values
2343         self#index_values
2344
2345     (** Generate the exceptions index in the file [index_exceptions.html]. *)
2346     method generate_exceptions_index module_list =
2347       self#generate_elements_index
2348         self#list_exceptions
2349         (fun e -> e.ex_name)
2350         (fun e -> e.ex_info)
2351         Naming.complete_exception_target
2352         Odoc_messages.index_of_exceptions
2353         self#index_exceptions
2354
2355     (** Generate the types index in the file [index_types.html]. *)
2356     method generate_types_index module_list =
2357       self#generate_elements_index
2358         self#list_types
2359         (fun t -> t.ty_name)
2360         (fun t -> t.ty_info)
2361         Naming.complete_type_target
2362         Odoc_messages.index_of_types
2363         self#index_types
2364
2365     (** Generate the attributes index in the file [index_attributes.html]. *)
2366     method generate_attributes_index module_list =
2367       self#generate_elements_index
2368         self#list_attributes
2369         (fun a -> a.att_value.val_name)
2370         (fun a -> a.att_value.val_info)
2371         Naming.complete_attribute_target
2372         Odoc_messages.index_of_attributes
2373         self#index_attributes
2374
2375     (** Generate the methods index in the file [index_methods.html]. *)
2376     method generate_methods_index module_list =
2377       self#generate_elements_index
2378         self#list_methods
2379         (fun m -> m.met_value.val_name)
2380         (fun m -> m.met_value.val_info)
2381         Naming.complete_method_target
2382         Odoc_messages.index_of_methods
2383         self#index_methods
2384
2385     (** Generate the classes index in the file [index_classes.html]. *)
2386     method generate_classes_index module_list =
2387       self#generate_elements_index
2388         self#list_classes
2389         (fun c -> c.cl_name)
2390         (fun c -> c.cl_info)
2391         (fun c -> fst (Naming.html_files c.cl_name))
2392         Odoc_messages.index_of_classes
2393         self#index_classes
2394
2395     (** Generate the class types index in the file [index_class_types.html]. *)
2396     method generate_class_types_index module_list =
2397       self#generate_elements_index
2398         self#list_class_types
2399         (fun ct -> ct.clt_name)
2400         (fun ct -> ct.clt_info)
2401         (fun ct -> fst (Naming.html_files ct.clt_name))
2402         Odoc_messages.index_of_class_types
2403         self#index_class_types
2404
2405     (** Generate the modules index in the file [index_modules.html]. *)
2406     method generate_modules_index module_list =
2407       self#generate_elements_index
2408         self#list_modules
2409         (fun m -> m.m_name)
2410         (fun m -> m.m_info)
2411         (fun m -> fst (Naming.html_files m.m_name))
2412         Odoc_messages.index_of_modules
2413         self#index_modules
2414
2415     (** Generate the module types index in the file [index_module_types.html]. *)
2416     method generate_module_types_index module_list =
2417       self#generate_elements_index
2418         self#list_module_types
2419         (fun mt -> mt.mt_name)
2420         (fun mt -> mt.mt_info)
2421         (fun mt -> fst (Naming.html_files mt.mt_name))
2422         Odoc_messages.index_of_module_types
2423         self#index_module_types
2424
2425     (** Generate all the html files from a module list. The main
2426        file is [<index_prefix>.html]. *)
2427     method generate module_list =
2428       (* init the style *)
2429       self#init_style ;
2430       (* init the lists of elements *)
2431       list_values <- Odoc_info.Search.values module_list ;
2432       list_exceptions <- Odoc_info.Search.exceptions module_list ;
2433       list_types <- Odoc_info.Search.types module_list ;
2434       list_attributes <- Odoc_info.Search.attributes module_list ;
2435       list_methods <- Odoc_info.Search.methods module_list ;
2436       list_classes <- Odoc_info.Search.classes module_list ;
2437       list_class_types <- Odoc_info.Search.class_types module_list ;
2438       list_modules <- Odoc_info.Search.modules module_list ;
2439       list_module_types <- Odoc_info.Search.module_types module_list ;
2440
2441       (* prepare the page header *)
2442       self#prepare_header module_list ;
2443       (* Get the names of all known types. *)
2444       let types = Odoc_info.Search.types module_list in
2445       known_types_names <-
2446         List.fold_left
2447           (fun acc t -> StringSet.add t.ty_name acc)
2448           known_types_names
2449           types ;
2450       (* Get the names of all class and class types. *)
2451       let classes = Odoc_info.Search.classes module_list in
2452       let class_types = Odoc_info.Search.class_types module_list in
2453       known_classes_names <-
2454         List.fold_left
2455           (fun acc c -> StringSet.add c.cl_name acc)
2456           known_classes_names
2457           classes ;
2458       known_classes_names <-
2459         List.fold_left
2460           (fun acc ct -> StringSet.add ct.clt_name acc)
2461           known_classes_names
2462           class_types ;
2463       (* Get the names of all known modules and module types. *)
2464       let module_types = Odoc_info.Search.module_types module_list in
2465       let modules = Odoc_info.Search.modules module_list in
2466       known_modules_names <-
2467         List.fold_left
2468           (fun acc m -> StringSet.add m.m_name acc)
2469           known_modules_names
2470           modules ;
2471       known_modules_names <-
2472         List.fold_left
2473           (fun acc mt -> StringSet.add mt.mt_name acc)
2474           known_modules_names
2475           module_types ;
2476       (* generate html for each module *)
2477       if not !Args.index_only then
2478         self#generate_elements self#generate_for_module module_list ;
2479
2480       try
2481         self#generate_index module_list;
2482         self#generate_values_index module_list ;
2483         self#generate_exceptions_index module_list ;
2484         self#generate_types_index module_list ;
2485         self#generate_attributes_index module_list ;
2486         self#generate_methods_index module_list ;
2487         self#generate_classes_index module_list ;
2488         self#generate_class_types_index module_list ;
2489         self#generate_modules_index module_list ;
2490         self#generate_module_types_index module_list ;
2491       with
2492         Failure s ->
2493           prerr_endline s ;
2494           incr Odoc_info.errors
2495
2496     initializer
2497       Odoc_ocamlhtml.html_of_comment :=
2498         (fun s ->
2499           let b = new_buf () in
2500           self#html_of_text b (Odoc_text.Texter.text_of_string s);
2501           Buffer.contents b
2502         )
2503   end