helm/DEVEL/pxp/pxp/doc/manual/src/readme.ent

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