helm/DEVEL/pxp/pxp/examples/readme/to_html.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6
   7 (*$ readme.code.header *)
   8 open Pxp_types
   9 open Pxp_document
  10 (*$-*)
  11
  12
  13 (*$ readme.code.footnote-printer *)
  14 class type footnote_printer =
  15   object
  16     method footnote_to_html : store_type -> out_channel -> unit
  17   end
  18
  19 and store_type =
  20   object
  21     method alloc_footnote : footnote_printer -> int
  22     method print_footnotes : out_channel -> unit
  23   end
  24 ;;
  25 (*$-*)
  26
  27
  28 (*$ readme.code.store *)
  29 class store =
  30   object (self)
  31
  32     val mutable footnotes = ( [] : (int * footnote_printer) list )
  33     val mutable next_footnote_number = 1
  34
  35     method alloc_footnote n =
  36       let number = next_footnote_number in
  37       next_footnote_number <- number+1;
  38       footnotes <- footnotes @ [ number, n ];
  39       number
  40
  41     method print_footnotes ch =
  42       if footnotes <> [] then begin
  43         output_string ch "<hr align=left noshade=noshade width=\"30%\">\n";
  44         output_string ch "<dl>\n";
  45         List.iter
  46           (fun (_,n) ->
  47              n # footnote_to_html (self : #store_type :> store_type) ch)
  48           footnotes;
  49         output_string ch "</dl>\n";
  50       end
  51
  52   end
  53 ;;
  54 (*$-*)
  55
  56
  57
  58 (*$ readme.code.escape-html *)
  59 let escape_html s =
  60   Str.global_substitute
  61     (Str.regexp "<\\|>\\|&\\|\"")
  62     (fun s ->
  63       match Str.matched_string s with
  64         "<" -> "&lt;"
  65       | ">" -> "&gt;"
  66       | "&" -> "&amp;"
  67       | "\"" -> "&quot;"
  68       | _ -> assert false)
  69     s
  70 ;;
  71 (*$-*)
  72
  73
  74 (*$ readme.code.shared *)
  75 class virtual shared =
  76   object (self)
  77
  78     (* --- default_ext --- *)
  79
  80     val mutable node = (None : shared node option)
  81
  82     method clone = {< >}
  83     method node =
  84       match node with
  85           None ->
  86             assert false
  87         | Some n -> n
  88     method set_node n =
  89       node <- Some n
  90
  91     (* --- virtual --- *)
  92
  93     method virtual to_html : store -> out_channel -> unit
  94
  95   end
  96 ;;
  97 (*$-*)
  98
  99
 100 (*$ readme.code.only-data *)
 101 class only_data =
 102   object (self)
 103     inherit shared
 104
 105     method to_html store ch =
 106       output_string ch (escape_html (self # node # data))
 107   end
 108 ;;
 109 (*$-*)
 110
 111
 112 (*$ readme.code.no-markup *)
 113 class no_markup =
 114   object (self)
 115     inherit shared
 116
 117     method to_html store ch =
 118       List.iter
 119         (fun n -> n # extension # to_html store ch)
 120         (self # node # sub_nodes)
 121   end
 122 ;;
 123 (*$-*)
 124
 125
 126 (*$ readme.code.readme *)
 127 class readme =
 128   object (self)
 129     inherit shared
 130
 131     method to_html store ch =
 132       (* output header *)
 133       output_string
 134         ch "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">";
 135       output_string
 136         ch "<!-- WARNING! This is a generated file, do not edit! -->\n";
 137       let title =
 138         match self # node # attribute "title" with
 139             Value s -> s
 140           | _ -> assert false
 141       in
 142       let html_header, _ =
 143         try (self # node # dtd # par_entity "readme:html:header")
 144             # replacement_text
 145         with WF_error _ -> "", false in
 146       let html_trailer, _ =
 147         try (self # node # dtd # par_entity "readme:html:trailer")
 148             # replacement_text
 149         with WF_error _ -> "", false in
 150       let html_bgcolor, _ =
 151         try (self # node # dtd # par_entity "readme:html:bgcolor")
 152             # replacement_text
 153         with WF_error _ -> "white", false in
 154       let html_textcolor, _ =
 155         try (self # node # dtd # par_entity "readme:html:textcolor")
 156             # replacement_text
 157         with WF_error _ -> "", false in
 158       let html_alinkcolor, _ =
 159         try (self # node # dtd # par_entity "readme:html:alinkcolor")
 160             # replacement_text
 161         with WF_error _ -> "", false in
 162       let html_vlinkcolor, _ =
 163         try (self # node # dtd # par_entity "readme:html:vlinkcolor")
 164             # replacement_text
 165         with WF_error _ -> "", false in
 166       let html_linkcolor, _ =
 167         try (self # node # dtd # par_entity "readme:html:linkcolor")
 168             # replacement_text
 169         with WF_error _ -> "", false in
 170       let html_background, _ =
 171         try (self # node # dtd # par_entity "readme:html:background")
 172             # replacement_text
 173         with WF_error _ -> "", false in
 174
 175       output_string ch "<html><header><title>\n";
 176       output_string ch (escape_html title);
 177       output_string ch "</title></header>\n";
 178       output_string ch "<body ";
 179       List.iter
 180         (fun (name,value) ->
 181            if value <> "" then
 182              output_string ch (name ^ "=\"" ^ escape_html value ^ "\" "))
 183         [ "bgcolor",    html_bgcolor;
 184           "text",       html_textcolor;
 185           "link",       html_linkcolor;
 186           "alink",      html_alinkcolor;
 187           "vlink",      html_vlinkcolor;
 188         ];
 189       output_string ch ">\n";
 190       output_string ch html_header;
 191       output_string ch "<h1>";
 192       output_string ch (escape_html title);
 193       output_string ch "</h1>\n";
 194       (* process main content: *)
 195       List.iter
 196         (fun n -> n # extension # to_html store ch)
 197         (self # node # sub_nodes);
 198       (* now process footnotes *)
 199       store # print_footnotes ch;
 200       (* trailer *)
 201       output_string ch html_trailer;
 202       output_string ch "</html>\n";
 203
 204   end
 205 ;;
 206 (*$-*)
 207
 208
 209 (*$ readme.code.section *)
 210 class section the_tag =
 211   object (self)
 212     inherit shared
 213
 214     val tag = the_tag
 215
 216     method to_html store ch =
 217       let sub_nodes = self # node # sub_nodes in
 218       match sub_nodes with
 219           title_node :: rest ->
 220             output_string ch ("<" ^ tag ^ ">\n");
 221             title_node # extension # to_html store ch;
 222             output_string ch ("\n</" ^ tag ^ ">");
 223             List.iter
 224               (fun n -> n # extension # to_html store ch)
 225               rest
 226         | _ ->
 227             assert false
 228   end
 229 ;;
 230
 231 class sect1 = section "h1";;
 232 class sect2 = section "h3";;
 233 class sect3 = section "h4";;
 234 (*$-*)
 235
 236
 237 (*$ readme.code.map-tag *)
 238 class map_tag the_target_tag =
 239   object (self)
 240     inherit shared
 241
 242     val target_tag = the_target_tag
 243
 244     method to_html store ch =
 245       output_string ch ("<" ^ target_tag ^ ">\n");
 246       List.iter
 247         (fun n -> n # extension # to_html store ch)
 248         (self # node # sub_nodes);
 249       output_string ch ("\n</" ^ target_tag ^ ">");
 250   end
 251 ;;
 252
 253 class p = map_tag "p";;
 254 class em = map_tag "b";;
 255 class ul = map_tag "ul";;
 256 class li = map_tag "li";;
 257 (*$-*)
 258
 259
 260 (*$ readme.code.br *)
 261 class br =
 262   object (self)
 263     inherit shared
 264
 265     method to_html store ch =
 266       output_string ch "<br>\n";
 267       List.iter
 268         (fun n -> n # extension # to_html store ch)
 269         (self # node # sub_nodes);
 270   end
 271 ;;
 272 (*$-*)
 273
 274
 275 (*$ readme.code.code *)
 276 class code =
 277   object (self)
 278     inherit shared
 279
 280     method to_html store ch =
 281       let data = self # node # data in
 282       (* convert tabs *)
 283       let l = String.length data in
 284       let rec preprocess i column =
 285         (* this is very ineffective but comprehensive: *)
 286         if i < l then
 287           match data.[i] with
 288               '\t' ->
 289                 let n = 8 - (column mod 8) in
 290                 String.make n ' ' ^ preprocess (i+1) (column + n)
 291             | '\n' ->
 292                 "\n" ^ preprocess (i+1) 0
 293             | c ->
 294                 String.make 1 c ^ preprocess (i+1) (column + 1)
 295         else
 296           ""
 297       in
 298       output_string ch "<p><pre>";
 299       output_string ch (escape_html (preprocess 0 0));
 300       output_string ch "</pre></p>";
 301
 302   end
 303 ;;
 304 (*$-*)
 305
 306
 307 (*$ readme.code.a *)
 308 class a =
 309   object (self)
 310     inherit shared
 311
 312     method to_html store ch =
 313       output_string ch "<a ";
 314       let href =
 315         match self # node # attribute "href" with
 316             Value v -> escape_html v
 317           | Valuelist _ -> assert false
 318           | Implied_value ->
 319               begin match self # node # attribute "readmeref" with
 320                   Value v -> escape_html v ^ ".html"
 321                 | Valuelist _ -> assert false
 322                 | Implied_value ->
 323                     ""
 324               end
 325       in
 326       if href <> "" then
 327         output_string ch ("href=\""  ^ href ^ "\"");
 328       output_string ch ">";
 329       output_string ch (escape_html (self # node # data));
 330       output_string ch "</a>";
 331
 332   end
 333 ;;
 334 (*$-*)
 335
 336
 337 (*$ readme.code.footnote *)
 338 class footnote =
 339   object (self)
 340     inherit shared
 341
 342     val mutable footnote_number = 0
 343
 344     method to_html store ch =
 345       let number =
 346         store # alloc_footnote (self : #shared :> footnote_printer) in
 347       let foot_anchor =
 348         "footnote" ^ string_of_int number in
 349       let text_anchor =
 350         "textnote" ^ string_of_int number in
 351       footnote_number <- number;
 352       output_string ch ( "<a name=\"" ^ text_anchor ^ "\" href=\"#" ^
 353                          foot_anchor ^ "\">[" ^ string_of_int number ^
 354                          "]</a>" )
 355
 356     method footnote_to_html store ch =
 357       (* prerequisite: we are in a definition list <dl>...</dl> *)
 358       let foot_anchor =
 359         "footnote" ^ string_of_int footnote_number in
 360       let text_anchor =
 361         "textnote" ^ string_of_int footnote_number in
 362       output_string ch ("<dt><a name=\"" ^ foot_anchor ^ "\" href=\"#" ^
 363                         text_anchor ^ "\">[" ^ string_of_int footnote_number ^
 364                         "]</a></dt>\n<dd>");
 365       List.iter
 366         (fun n -> n # extension # to_html store ch)
 367         (self # node # sub_nodes);
 368       output_string ch ("\n</dd>")
 369
 370   end
 371 ;;
 372 (*$-*)
 373
 374
 375 (**********************************************************************)
 376
 377 (*$ readme.code.tag-map *)
 378 open Pxp_yacc
 379
 380 let tag_map =
 381   make_spec_from_alist
 382     ~data_exemplar:(new data_impl (new only_data))
 383     ~default_element_exemplar:(new element_impl (new no_markup))
 384     ~element_alist:
 385       [ "readme", (new element_impl (new readme));
 386         "sect1",  (new element_impl (new sect1));
 387         "sect2",  (new element_impl (new sect2));
 388         "sect3",  (new element_impl (new sect3));
 389         "title",  (new element_impl (new no_markup));
 390         "p",      (new element_impl (new p));
 391         "br",     (new element_impl (new br));
 392         "code",   (new element_impl (new code));
 393         "em",     (new element_impl (new em));
 394         "ul",     (new element_impl (new ul));
 395         "li",     (new element_impl (new li));
 396         "footnote", (new element_impl (new footnote : #shared :> shared));
 397         "a",      (new element_impl (new a));
 398       ]
 399     ()
 400 ;;
 401 (*$-*)
 402
 403
 404 (* ======================================================================
 405  * History:
 406  *
 407  * $Log$
 408  * Revision 1.1  2000/11/17 09:57:31  lpadovan
 409  * Initial revision
 410  *
 411  * Revision 1.6  2000/08/22 14:34:25  gerd
 412  *      Using make_spec_from_alist instead of make_spec_from_mapping.
 413  *
 414  * Revision 1.5  2000/08/18 21:15:14  gerd
 415  *      Update because of PXP API change: par_entity raises WF_error
 416  * instead of Validation error if the entity is not defined.
 417  *      Further minor updates.
 418  *
 419  * Revision 1.4  2000/07/08 17:58:17  gerd
 420  *      Updated because of PXP API changes.
 421  *
 422  * Revision 1.3  2000/06/04 20:25:38  gerd
 423  *      Updates because of renamed PXP modules.
 424  *
 425  * Revision 1.2  1999/09/12 20:09:32  gerd
 426  *      Added section marks.
 427  *
 428  * Revision 1.1  1999/08/22 22:29:32  gerd
 429  *      Initial revision.
 430  *
 431  *
 432  *)