--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+
+(*$ readme.code.header *)
+open Pxp_types
+open Pxp_document
+(*$-*)
+
+
+(*$ readme.code.footnote-printer *)
+class type footnote_printer =
+ object
+ method footnote_to_html : store_type -> out_channel -> unit
+ end
+
+and store_type =
+ object
+ method alloc_footnote : footnote_printer -> int
+ method print_footnotes : out_channel -> unit
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.store *)
+class store =
+ object (self)
+
+ val mutable footnotes = ( [] : (int * footnote_printer) list )
+ val mutable next_footnote_number = 1
+
+ method alloc_footnote n =
+ let number = next_footnote_number in
+ next_footnote_number <- number+1;
+ footnotes <- footnotes @ [ number, n ];
+ number
+
+ method print_footnotes ch =
+ if footnotes <> [] then begin
+ output_string ch "<hr align=left noshade=noshade width=\"30%\">\n";
+ output_string ch "<dl>\n";
+ List.iter
+ (fun (_,n) ->
+ n # footnote_to_html (self : #store_type :> store_type) ch)
+ footnotes;
+ output_string ch "</dl>\n";
+ end
+
+ end
+;;
+(*$-*)
+
+
+
+(*$ readme.code.escape-html *)
+let escape_html s =
+ Str.global_substitute
+ (Str.regexp "<\\|>\\|&\\|\"")
+ (fun s ->
+ match Str.matched_string s with
+ "<" -> "<"
+ | ">" -> ">"
+ | "&" -> "&"
+ | "\"" -> """
+ | _ -> assert false)
+ s
+;;
+(*$-*)
+
+
+(*$ readme.code.shared *)
+class virtual shared =
+ object (self)
+
+ (* --- default_ext --- *)
+
+ val mutable node = (None : shared node option)
+
+ method clone = {< >}
+ method node =
+ match node with
+ None ->
+ assert false
+ | Some n -> n
+ method set_node n =
+ node <- Some n
+
+ (* --- virtual --- *)
+
+ method virtual to_html : store -> out_channel -> unit
+
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.only-data *)
+class only_data =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ output_string ch (escape_html (self # node # data))
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.no-markup *)
+class no_markup =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ (self # node # sub_nodes)
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.readme *)
+class readme =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ (* output header *)
+ output_string
+ ch "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">";
+ output_string
+ ch "<!-- WARNING! This is a generated file, do not edit! -->\n";
+ let title =
+ match self # node # attribute "title" with
+ Value s -> s
+ | _ -> assert false
+ in
+ let html_header, _ =
+ try (self # node # dtd # par_entity "readme:html:header")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_trailer, _ =
+ try (self # node # dtd # par_entity "readme:html:trailer")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_bgcolor, _ =
+ try (self # node # dtd # par_entity "readme:html:bgcolor")
+ # replacement_text
+ with WF_error _ -> "white", false in
+ let html_textcolor, _ =
+ try (self # node # dtd # par_entity "readme:html:textcolor")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_alinkcolor, _ =
+ try (self # node # dtd # par_entity "readme:html:alinkcolor")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_vlinkcolor, _ =
+ try (self # node # dtd # par_entity "readme:html:vlinkcolor")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_linkcolor, _ =
+ try (self # node # dtd # par_entity "readme:html:linkcolor")
+ # replacement_text
+ with WF_error _ -> "", false in
+ let html_background, _ =
+ try (self # node # dtd # par_entity "readme:html:background")
+ # replacement_text
+ with WF_error _ -> "", false in
+
+ output_string ch "<html><header><title>\n";
+ output_string ch (escape_html title);
+ output_string ch "</title></header>\n";
+ output_string ch "<body ";
+ List.iter
+ (fun (name,value) ->
+ if value <> "" then
+ output_string ch (name ^ "=\"" ^ escape_html value ^ "\" "))
+ [ "bgcolor", html_bgcolor;
+ "text", html_textcolor;
+ "link", html_linkcolor;
+ "alink", html_alinkcolor;
+ "vlink", html_vlinkcolor;
+ ];
+ output_string ch ">\n";
+ output_string ch html_header;
+ output_string ch "<h1>";
+ output_string ch (escape_html title);
+ output_string ch "</h1>\n";
+ (* process main content: *)
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ (self # node # sub_nodes);
+ (* now process footnotes *)
+ store # print_footnotes ch;
+ (* trailer *)
+ output_string ch html_trailer;
+ output_string ch "</html>\n";
+
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.section *)
+class section the_tag =
+ object (self)
+ inherit shared
+
+ val tag = the_tag
+
+ method to_html store ch =
+ let sub_nodes = self # node # sub_nodes in
+ match sub_nodes with
+ title_node :: rest ->
+ output_string ch ("<" ^ tag ^ ">\n");
+ title_node # extension # to_html store ch;
+ output_string ch ("\n</" ^ tag ^ ">");
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ rest
+ | _ ->
+ assert false
+ end
+;;
+
+class sect1 = section "h1";;
+class sect2 = section "h3";;
+class sect3 = section "h4";;
+(*$-*)
+
+
+(*$ readme.code.map-tag *)
+class map_tag the_target_tag =
+ object (self)
+ inherit shared
+
+ val target_tag = the_target_tag
+
+ method to_html store ch =
+ output_string ch ("<" ^ target_tag ^ ">\n");
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ (self # node # sub_nodes);
+ output_string ch ("\n</" ^ target_tag ^ ">");
+ end
+;;
+
+class p = map_tag "p";;
+class em = map_tag "b";;
+class ul = map_tag "ul";;
+class li = map_tag "li";;
+(*$-*)
+
+
+(*$ readme.code.br *)
+class br =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ output_string ch "<br>\n";
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ (self # node # sub_nodes);
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.code *)
+class code =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ let data = self # node # data in
+ (* convert tabs *)
+ let l = String.length data in
+ let rec preprocess i column =
+ (* this is very ineffective but comprehensive: *)
+ if i < l then
+ match data.[i] with
+ '\t' ->
+ let n = 8 - (column mod 8) in
+ String.make n ' ' ^ preprocess (i+1) (column + n)
+ | '\n' ->
+ "\n" ^ preprocess (i+1) 0
+ | c ->
+ String.make 1 c ^ preprocess (i+1) (column + 1)
+ else
+ ""
+ in
+ output_string ch "<p><pre>";
+ output_string ch (escape_html (preprocess 0 0));
+ output_string ch "</pre></p>";
+
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.a *)
+class a =
+ object (self)
+ inherit shared
+
+ method to_html store ch =
+ output_string ch "<a ";
+ let href =
+ match self # node # attribute "href" with
+ Value v -> escape_html v
+ | Valuelist _ -> assert false
+ | Implied_value ->
+ begin match self # node # attribute "readmeref" with
+ Value v -> escape_html v ^ ".html"
+ | Valuelist _ -> assert false
+ | Implied_value ->
+ ""
+ end
+ in
+ if href <> "" then
+ output_string ch ("href=\"" ^ href ^ "\"");
+ output_string ch ">";
+ output_string ch (escape_html (self # node # data));
+ output_string ch "</a>";
+
+ end
+;;
+(*$-*)
+
+
+(*$ readme.code.footnote *)
+class footnote =
+ object (self)
+ inherit shared
+
+ val mutable footnote_number = 0
+
+ method to_html store ch =
+ let number =
+ store # alloc_footnote (self : #shared :> footnote_printer) in
+ let foot_anchor =
+ "footnote" ^ string_of_int number in
+ let text_anchor =
+ "textnote" ^ string_of_int number in
+ footnote_number <- number;
+ output_string ch ( "<a name=\"" ^ text_anchor ^ "\" href=\"#" ^
+ foot_anchor ^ "\">[" ^ string_of_int number ^
+ "]</a>" )
+
+ method footnote_to_html store ch =
+ (* prerequisite: we are in a definition list <dl>...</dl> *)
+ let foot_anchor =
+ "footnote" ^ string_of_int footnote_number in
+ let text_anchor =
+ "textnote" ^ string_of_int footnote_number in
+ output_string ch ("<dt><a name=\"" ^ foot_anchor ^ "\" href=\"#" ^
+ text_anchor ^ "\">[" ^ string_of_int footnote_number ^
+ "]</a></dt>\n<dd>");
+ List.iter
+ (fun n -> n # extension # to_html store ch)
+ (self # node # sub_nodes);
+ output_string ch ("\n</dd>")
+
+ end
+;;
+(*$-*)
+
+
+(**********************************************************************)
+
+(*$ readme.code.tag-map *)
+open Pxp_yacc
+
+let tag_map =
+ make_spec_from_alist
+ ~data_exemplar:(new data_impl (new only_data))
+ ~default_element_exemplar:(new element_impl (new no_markup))
+ ~element_alist:
+ [ "readme", (new element_impl (new readme));
+ "sect1", (new element_impl (new sect1));
+ "sect2", (new element_impl (new sect2));
+ "sect3", (new element_impl (new sect3));
+ "title", (new element_impl (new no_markup));
+ "p", (new element_impl (new p));
+ "br", (new element_impl (new br));
+ "code", (new element_impl (new code));
+ "em", (new element_impl (new em));
+ "ul", (new element_impl (new ul));
+ "li", (new element_impl (new li));
+ "footnote", (new element_impl (new footnote : #shared :> shared));
+ "a", (new element_impl (new a));
+ ]
+ ()
+;;
+(*$-*)
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:31 lpadovan
+ * Initial revision
+ *
+ * Revision 1.6 2000/08/22 14:34:25 gerd
+ * Using make_spec_from_alist instead of make_spec_from_mapping.
+ *
+ * Revision 1.5 2000/08/18 21:15:14 gerd
+ * Update because of PXP API change: par_entity raises WF_error
+ * instead of Validation error if the entity is not defined.
+ * Further minor updates.
+ *
+ * Revision 1.4 2000/07/08 17:58:17 gerd
+ * Updated because of PXP API changes.
+ *
+ * Revision 1.3 2000/06/04 20:25:38 gerd
+ * Updates because of renamed PXP modules.
+ *
+ * Revision 1.2 1999/09/12 20:09:32 gerd
+ * Added section marks.
+ *
+ * Revision 1.1 1999/08/22 22:29:32 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff