(* $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 "
\n";
output_string ch "\n";
List.iter
(fun (_,n) ->
n # footnote_to_html (self : #store_type :> store_type) ch)
footnotes;
output_string ch "
\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 "";
output_string
ch "\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 "\n";
output_string ch (escape_html title);
output_string ch "\n";
output_string ch "
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 "";
output_string ch (escape_html title);
output_string ch "
\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 "\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");
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");
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 "
\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 "";
output_string ch (escape_html (preprocess 0 0));
output_string ch "";
end
;;
(*$-*)
(*$ readme.code.a *)
class a =
object (self)
inherit shared
method to_html store ch =
output_string ch " 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 "";
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 ( "[" ^ string_of_int number ^
"]" )
method footnote_to_html store ch =
(* prerequisite: we are in a definition list ...
*)
let foot_anchor =
"footnote" ^ string_of_int footnote_number in
let text_anchor =
"textnote" ^ string_of_int footnote_number in
output_string ch ("[" ^ string_of_int footnote_number ^
"]\n");
List.iter
(fun n -> n # extension # to_html store ch)
(self # node # sub_nodes);
output_string ch ("\n")
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.
*
*
*)