+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- *
- *)
-
-open Pxp_types
-open Pxp_document
-
-
-(**********************************************************************)
-(* The box class represents formatted text *)
-(**********************************************************************)
-
-class type formatted_text =
- object
- method output : int -> int -> out_channel -> unit
- (* output initial_indent indent ch:
- * 'initial_indent' is how far the first line should be indented;
- * 'indent' how far the rest. 'ch' is the channel on which the lines
- * are to be printed.
- *)
-
- method multiline : bool
- (* whether the box occupies multiple lines *)
-
- method width_of_last_line : int
- (* returns the width of the last line *)
- end
-;;
-
-
-type text =
- Text of string
- | Box of formatted_text
-;;
-
-
-let textwidth tl =
- let rec compute tl r =
- match tl with
- [] -> r
- | t :: tl' ->
- begin match t with
- Text s ->
- compute tl' (r + String.length s)
- | Box b ->
- if b # multiline then
- compute tl' (b # width_of_last_line)
- else
- compute tl' (r + b # width_of_last_line)
- end
- in
- compute (List.rev tl) 0
-;;
-
-
-class box the_initial_width the_width =
- object (self)
-
- (* The 'initial_width' is the width that is available on the first
- * line of output; the 'width' is the width that is available in the
- * rest.
- *)
-
- val initial_width = the_initial_width
- val width = the_width
-
- (* state: *)
-
- val mutable space_added = false
- val mutable linefeed_added = false
- val mutable is_first_line = true
- val mutable lines = []
- (* lines in reverse order (first line = last element) *)
- val mutable current_line = []
- (* not member of 'lines'; again reverse order *)
- val mutable current_indent = 0
-
- method add_space =
- if not space_added then begin
- space_added <- true;
- linefeed_added <- true;
- current_line <- Text " " :: current_line
- end
-
- method ignore_space =
- space_added <- true;
- linefeed_added <- true
-
- method add_linefeed =
- if not linefeed_added then begin
- linefeed_added <- true;
- if not space_added then
- current_line <- Text " " :: current_line
- end
-
- method ignore_linefeed =
- linefeed_added <- true
-
- method add_newline =
- lines <- current_line :: lines;
- current_line <- [];
- space_added <- true;
- linefeed_added <- true;
- is_first_line <- false;
- current_indent <- 0;
-
- method add_word s =
- (* first try to add 's' to 'current_line' *)
- let current_line' = Text s :: current_line in
- let current_width =
- if is_first_line then initial_width else width in
- if textwidth current_line' + current_indent <= current_width then begin
- (* ok, the line does not become too long *)
- current_line <- current_line';
- space_added <- false;
- linefeed_added <- false
- end
- else begin
- (* The line would be too long. *)
- lines <- current_line :: lines;
- current_line <- [Text s];
- space_added <- false;
- linefeed_added <- false;
- is_first_line <- false;
- current_indent <- 0;
- end
-
- method add_box b =
- current_line <- Box b :: current_line;
- space_added <- false;
- linefeed_added <- false;
-
-
- method width_of_last_line =
- textwidth current_line + current_indent
-
-
- method available_width =
- let current_width =
- if is_first_line then initial_width else width in
- current_width - textwidth current_line - current_indent
-
-
- method multiline =
- lines <> [] or
- (List.exists
- (function
- Text _ -> false
- | Box b -> b # multiline)
- current_line)
-
- method output initial_indent indent ch =
- let eff_lines =
- List.rev
- (current_line :: lines) in
- let rec out_lines cur_indent ll =
- match ll with
- [] -> ()
- | l :: ll' ->
- output_string ch (String.make cur_indent ' ');
- List.iter
- (function
- Text s ->
- output_string ch s
- | Box b ->
- b # output 0 indent ch
- )
- (List.rev l);
- if ll' <> [] then
- output_string ch "\n";
- out_lines indent ll'
- in
- out_lines initial_indent eff_lines
- end
-;;
-
-
-class listitem_box listmark indent totalwidth =
- let initial_newline = String.length listmark >= indent in
- object (self)
- inherit box totalwidth (totalwidth - indent) as super
-
- val extra_indent = indent
-
- initializer
- self # add_word listmark;
- if initial_newline then
- self # add_newline
- else begin
- current_line <- Text (String.make (indent - String.length listmark) ' ')
- :: current_line;
- space_added <- true;
- linefeed_added <- true;
- end
-
-
- method output initial_indent indent ch =
- super # output initial_indent (indent + extra_indent) ch
- end
-;;
-
-
-(**********************************************************************)
-(* Footnotes etc. *)
-(**********************************************************************)
-
-
-class type footnote_printer =
- object
- method footnote_to_box : store_type -> box -> unit
- end
-
-and store_type =
- object
- method alloc_footnote : footnote_printer -> int
- method print_footnotes : box -> unit
- end
-;;
-
-
-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 (b : box) =
- if footnotes <> [] then begin
- b # add_newline;
- b # add_newline;
- let w = b # available_width in
- b # add_word (String.make (w/3) '-');
- b # add_newline;
- b # add_newline;
- List.iter
- (fun (_,n) ->
- n # footnote_to_box (self : #store_type :> store_type) b)
- footnotes;
- b # add_newline;
- end
- end
-;;
-
-
-
-(**********************************************************************)
-(* The extension objects *)
-(**********************************************************************)
-
-
-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_box : store -> box -> unit
- (* to_box store b:
- * formats the element using box 'b'
- *)
- end
-;;
-
-
-class only_data =
- object (self)
- inherit shared
-
- val white_space_re = Str.regexp "[ \t]+\\|\n"
-
- method to_box store b =
- let s = self # node # data in
- let splitted = Str.full_split white_space_re s in
- List.iter
- (function
- Str.Delim "\n" ->
- b # add_linefeed
- | Str.Delim _ ->
- b # add_space
- | Str.Text s ->
- b # add_word s)
- splitted
- end
-;;
-
-
-class no_markup =
- object (self)
- inherit shared
-
- method to_box store b =
- List.iter
- (fun n -> n # extension # to_box store b)
- (self # node # sub_nodes)
- end
-;;
-
-
-class readme =
- object (self)
- inherit shared
-
- method to_box store b =
- let title =
- match self # node # attribute "title" with
- Value s -> s
- | _ -> assert false
- in
- let w = b # available_width in
- let line = String.make (w-1) '*' in
- b # add_word line;
- b # add_newline;
- b # add_word title;
- b # add_newline;
- b # add_word line;
- b # add_newline;
- b # add_newline;
- (* process main content: *)
- List.iter
- (fun n -> n # extension # to_box store b)
- (self # node # sub_nodes);
- (* now process footnotes *)
- store # print_footnotes b;
- (* trailer *)
- b # add_newline;
- end
-;;
-
-
-class section the_tag =
- object (self)
- inherit shared
-
- val tag = the_tag
-
- method to_box store b =
- let sub_nodes = self # node # sub_nodes in
- match sub_nodes with
- title_node :: rest ->
- b # add_newline;
- let w = b # available_width in
- let line = String.make (w-1) tag in
- b # add_word line;
- b # add_newline;
- b # add_word (title_node # data);
- b # add_newline;
- b # add_word line;
- b # add_newline;
- List.iter
- (fun n ->
- n # extension # to_box store b)
- rest;
- | _ ->
- assert false
- end
-;;
-
-class sect1 = section '=';;
-class sect2 = section '-';;
-class sect3 = section ':';;
-
-
-class p =
- object (self)
- inherit shared
-
- method to_box store b =
- let within_list =
- match self # node # parent # node_type with
- T_element "li" -> true
- | T_element _ -> false
- | _ -> assert false
- in
- if not within_list then
- b # add_newline;
- let w = b # available_width in
- let b' = new box w w in
- b' # ignore_space;
- List.iter
- (fun n -> n # extension # to_box store b')
- (self # node # sub_nodes);
- b # add_box (b' :> formatted_text);
- b # add_newline;
- end
-;;
-
-
-class li =
- object (self)
- inherit shared
-
- method to_box store b =
- b # add_newline;
- let w = b # available_width in
- let b' = new listitem_box "-" 3 w in
- b' # ignore_space;
- List.iter
- (fun n -> n # extension # to_box store b')
- (self # node # sub_nodes);
- b # add_box (b' :> formatted_text);
- end
-;;
-
-
-class code =
- object (self)
- inherit shared
-
- method to_box store b =
- b # add_newline;
- let w = b # available_width in
- let b' = new box w w in
- b' # ignore_space;
- let data = self # node # data in
- (* convert tabs *)
- let l = String.length data in
- let rec add s i column =
- (* this is very ineffective but comprehensive: *)
- if i < l then
- match data.[i] with
- '\t' ->
- let n = 8 - (column mod 8) in
- add (s ^ String.make n ' ') (i+1) (column + n)
- | '\n' ->
- b' # add_word s;
- b' # add_newline;
- add "" (i+1) 0
- | c ->
- add (s ^ String.make 1 c) (i+1) (column + 1)
- else
- if s <> "" then begin
- b' # add_word s;
- b' # add_newline;
- end
- in
- add "" 0 0;
- b # add_box (b' :> formatted_text);
- b # add_newline;
- end
-;;
-
-
-class br =
- object (self)
- inherit shared
-
- method to_box store b =
- b # add_newline;
- end
-;;
-
-
-class footnote =
- object (self)
- inherit shared
-
- val mutable footnote_number = 0
-
- method to_box store b =
- let number =
- store # alloc_footnote (self : #shared :> footnote_printer) in
- footnote_number <- number;
- b # add_space;
- b # add_word ("[" ^ string_of_int number ^ "]");
-
- method footnote_to_box store b =
- let w = b # available_width in
- let n = "[" ^ string_of_int footnote_number ^ "]" in
- let b' = new listitem_box n 6 w in
- b' # ignore_space;
- List.iter
- (fun n -> n # extension # to_box store b')
- (self # node # sub_nodes);
- b # add_box (b' :> formatted_text);
- b # add_newline;
- b # add_newline;
-
- end
-;;
-
-
-class a =
- object (self)
- inherit shared
-
- val mutable footnote_number = 0
- val mutable a_href = ""
-
- method to_box store b =
- let href =
- match self # node # attribute "href" with
- Value v -> "see " ^ v
- | Valuelist _ -> assert false
- | Implied_value ->
- begin match self # node # attribute "readmeref" with
- Value v -> "see file " ^ v
- | Valuelist _ -> assert false
- | Implied_value ->
- ""
- end
- in
- a_href <- href;
- List.iter
- (fun n -> n # extension # to_box store b)
- (self # node # sub_nodes);
- if href <> "" then begin
- let number =
- store # alloc_footnote (self : #shared :> footnote_printer) in
- footnote_number <- number;
- b # add_space;
- b # add_word ("[" ^ string_of_int number ^ "]");
- end
-
- method footnote_to_box store b =
- if a_href <> "" then begin
- let w = b # available_width in
- let n = "[" ^ string_of_int footnote_number ^ "]" in
- let b' = new listitem_box n 6 w in
- b' # ignore_space;
- b' # add_word a_href;
- b # add_box (b' :> formatted_text);
- b # add_newline;
- b # add_newline;
- end
- end
-;;
-
-(**********************************************************************)
-
-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 no_markup));
- "ul", (new element_impl (new no_markup));
- "li", (new element_impl (new li));
- "footnote", (new element_impl (new footnote : #shared :> shared));
- "a", (new element_impl (new a : #shared :> shared));
- ]
- ()
-;;
-
-
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:31 lpadovan
- * Initial revision
- *
- * Revision 1.5 2000/08/22 14:34:25 gerd
- * Using make_spec_from_alist instead of make_spec_from_mapping.
- *
- * Revision 1.4 2000/08/18 21:15:25 gerd
- * Minor updates because of PXP API changes.
- *
- * Revision 1.3 2000/07/08 17:58:17 gerd
- * Updated because of PXP API changes.
- *
- * Revision 1.2 2000/06/04 20:25:38 gerd
- * Updates because of renamed PXP modules.
- *
- * Revision 1.1 1999/08/22 22:29:32 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff