ocaml/stdlib/format.ml

510 lines
18 KiB
OCaml

(***********************************************************************)
(* *)
(* Caml Special Light *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1995 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Tokens are one of the following : *)
type pp_token =
Pp_text of string (* normal text *)
| Pp_break of int * int (* complete break *)
| Pp_tbreak of int * int (* go to next tab *)
| Pp_stab (* set a tabulation *)
| Pp_begin of int * block_type (* beginning of a block *)
| Pp_end (* end of a block *)
| Pp_tbegin of tblock (* Beginning of a tabulation block *)
| Pp_tend (* end of a tabulation block *)
| Pp_newline (* to force a newline inside a block *)
| Pp_if_newline (* to do something only if this very
line has been broken *)
and block_type =
Pp_hbox (* Horizontal block no line breaking *)
| Pp_vbox (* Vertical block each break leads to a new line *)
| Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block
is small enough to fit on a single line *)
| Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line
only when necessary to print the content of the block *)
| Pp_fits (* Internal usage: when a block fits on a single line *)
and tblock = Pp_tbox of int list ref (* Tabulation box *)
(* The Queue: contains all formatting elements.
elements are tuples (size,token,length), where
size is set when the size of the block is known
len is the declared length of the token *)
type pp_queue_elem =
{mutable elem_size : int; token : pp_token; length : int}
(* Scan stack
each element is (left_total, queue element) where left_total
is the value of pp_left_total when the element has been enqueued *)
type pp_scan_elem = Scan_elem of int * pp_queue_elem
let pp_scan_stack = ref ([] : pp_scan_elem list)
(* Formatting Stack:
used to break the lines while printing tokens.
The formatting stack contains the description of
the currently active blocks. *)
type pp_format_elem = Format_elem of block_type * int
let pp_format_stack = ref ([] : pp_format_elem list)
let pp_tbox_stack = ref ([]:tblock list)
(* Large value for default tokens size *)
let pp_infinity = 9999
(* Global variables: default initialization is
set_margin 78
set_min_space_left 0 *)
(* value of right margin *)
let pp_margin = ref 78
(* Minimal space left before margin, when opening a block *)
let pp_min_space_left = ref 10
(* maximum value of indentation:
no blocks can be opened further *)
let pp_max_indent = ref (!pp_margin - !pp_min_space_left)
let pp_space_left = ref !pp_margin(* space remaining on the current line *)
and pp_current_indent = ref 0 (* current value of indentation *)
and pp_left_total = ref 1 (* total width of tokens already printed *)
and pp_right_total = ref 1 (* total width of tokens ever put in queue *)
and pp_curr_depth = ref 0 (* current number of opened blocks *)
and pp_max_boxes = ref 35 (* maximum number of blocks which can be
opened at the same time *)
and pp_ellipsis = ref "." (* ellipsis string *)
(* Current outputs *)
type formatter_output =
{ mutable output_function: string -> int -> int -> unit;
mutable flush_function: unit -> unit }
let current_output =
{ output_function = output stdout;
flush_function = fun () -> flush stdout }
(* Output functions for the formatter *)
let pp_output_string s = current_output.output_function s 0 (String.length s)
and pp_output_newline () = current_output.output_function "\n" 0 1
(* The pretty-printer queue *)
let pp_queue = (Queue.new () : pp_queue_elem Queue.t)
let pp_clear_queue () =
pp_left_total := 1; pp_right_total := 1;
Queue.clear pp_queue
(* Enter a token in the pretty-printer queue *)
let pp_enqueue ({length=len} as token) =
pp_right_total := !pp_right_total + len;
Queue.add token pp_queue
(* To output spaces *)
let blank_line = String.make 80 ' '
let display_blanks n =
if n > 0 then
if n <= 80
then current_output.output_function blank_line 0 n
else pp_output_string (String.make n ' ')
(* To format a break, indenting a new line *)
let break_new_line offset width =
pp_output_newline ();
let indent = !pp_margin - width + offset in
(* Don't indent more than pp_max_indent *)
let real_indent = min !pp_max_indent indent in
pp_current_indent := real_indent;
pp_space_left := !pp_margin - !pp_current_indent;
display_blanks !pp_current_indent
(* To force a line break inside a block: no offset is added *)
let break_line width = break_new_line 0 width
(* To format a break that fits on the current line *)
let break_same_line width =
pp_space_left := !pp_space_left - width;
display_blanks width
(* To indent no more than pp_max_indent, if one tries to open a block
beyond pp_max_indent, then the block is rejected on the left
by simulating a break. *)
let pp_force_newline () =
match !pp_format_stack with
Format_elem (bl_ty, width) :: _ ->
if width > !pp_space_left then
(match bl_ty with
Pp_fits -> () | Pp_hbox -> () | _ -> break_line width)
| _ -> pp_output_newline()
(* To skip a token, if the previous line has been broken *)
let pp_skip_token () =
(* When calling pp_skip_token the queue cannot be empty *)
match Queue.take pp_queue with
{elem_size = size; length = len} ->
pp_left_total := !pp_left_total - len;
pp_space_left := !pp_space_left + size
(* To format a token *)
let format_pp_token size = function
Pp_text s -> pp_space_left := !pp_space_left - size; pp_output_string s
| Pp_begin (off,ty) ->
let insertion_point = !pp_margin - !pp_space_left in
if insertion_point > !pp_max_indent then
(* can't open a block right there ! *)
begin pp_force_newline () end;
(* If block is rejected on the left current indentation will change
else if size > !pp_space_left &
!pp_current_indent < insertion_point
then pp_force_newline (); *)
let offset = !pp_space_left - off in
let bl_type =
begin match ty with
Pp_vbox -> Pp_vbox
| _ -> if size > !pp_space_left then ty else Pp_fits
end in
pp_format_stack := Format_elem (bl_type, offset) :: !pp_format_stack
| Pp_end ->
begin match !pp_format_stack with
x::(y::l as ls) -> pp_format_stack := ls
| _ -> () (* No more block to close *)
end
| Pp_tbegin (Pp_tbox _ as tbox) -> pp_tbox_stack := tbox :: !pp_tbox_stack
| Pp_tend ->
begin match !pp_tbox_stack with
x::ls -> pp_tbox_stack := ls
| _ -> () (* No more tabulation block to close *)
end
| Pp_stab ->
begin match !pp_tbox_stack with
Pp_tbox tabs :: _ ->
let rec add_tab n = function
[] -> [n]
| x::l as ls -> if n < x then n :: ls else x::add_tab n l in
tabs := add_tab (!pp_margin - !pp_space_left) !tabs
| _ -> () (* No opened tabulation block *)
end
| Pp_tbreak (n,off) ->
let insertion_point = !pp_margin - !pp_space_left in
begin match !pp_tbox_stack with
Pp_tbox tabs :: _ ->
let rec find n = function
x :: l -> if x >= n then x else find n l
| [] -> raise Not_found in
let tab =
match !tabs with
x :: l ->
begin try find insertion_point !tabs with Not_found -> x end
| _ -> insertion_point in
let offset = tab - insertion_point in
if offset >= 0 then break_same_line (offset + n) else
break_new_line (tab + off) !pp_margin
| _ -> () (* No opened tabulation block *)
end
| Pp_newline ->
begin match !pp_format_stack with
Format_elem (_,width) :: _ -> break_line width
| _ -> pp_output_newline()
end
| Pp_if_newline ->
if !pp_current_indent != !pp_margin - !pp_space_left
then pp_skip_token ()
| Pp_break (n,off) ->
begin match !pp_format_stack with
Format_elem (ty,width) :: _ ->
begin match ty with
Pp_hovbox ->
if size > !pp_space_left then break_new_line off width else
(* break the line here leads to new indentation ? *)
if (!pp_current_indent > !pp_margin - width + off)
then break_new_line off width else break_same_line n
| Pp_hvbox -> break_new_line off width
| Pp_fits -> break_same_line n
| Pp_vbox -> break_new_line off width
| Pp_hbox -> break_same_line n
end
| _ -> () (* No opened block *)
end
(* Print if token size is known or printing is delayed
Size is known when not negative
Printing is delayed when the text waiting in the queue requires
more room to format than List.exists on the current line *)
let rec advance_left () =
try
match Queue.peek pp_queue with
{elem_size = size; token = tok; length = len} ->
if not (size < 0 &
(!pp_right_total - !pp_left_total < !pp_space_left)) then
begin
Queue.take pp_queue;
format_pp_token (if size < 0 then pp_infinity else size) tok;
pp_left_total := len + !pp_left_total;
advance_left ()
end
with Queue.Empty -> ()
let enqueue_advance tok = pp_enqueue tok; advance_left ()
(* To enqueue a string : try to advance *)
let enqueue_string_as n s =
enqueue_advance {elem_size = n; token = Pp_text s; length = n}
let enqueue_string s = enqueue_string_as (String.length s) s
(* Routines for scan stack
determine sizes of blocks *)
(* scan_stack is never empty *)
let empty_scan_stack =
[Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})]
let clear_scan_stack () = pp_scan_stack := empty_scan_stack
(* Set size of blocks on scan stack:
if ty = true then size of break is set else size of block is set
in each case pp_scan_stack is popped *)
(* Pattern matching on scan stack is exhaustive,
since scan_stack is never empty.
Pattern matching on token in scan stack is also exhaustive,
since scan_push is used on breaks and opening of boxes *)
let set_size ty =
match !pp_scan_stack with
Scan_elem (left_tot,
({elem_size = size; token = tok} as queue_elem)) :: t ->
(* test if scan stack contains any data that is not obsolete *)
if left_tot < !pp_left_total then clear_scan_stack () else
begin match tok with
Pp_break (_, _) | Pp_tbreak (_, _) ->
if ty then
begin
queue_elem.elem_size <- !pp_right_total + size;
pp_scan_stack := t
end
| Pp_begin (_, _) ->
if not ty then
begin
queue_elem.elem_size <- !pp_right_total + size;
pp_scan_stack := t
end
| _ -> () (* scan_push is only used for breaks and boxes *)
end
| _ -> () (* scan_stack is never empty *)
(* Push a token on scan stack. If b is true set_size is called *)
let scan_push b tok =
pp_enqueue tok;
if b then set_size true;
pp_scan_stack := Scan_elem (!pp_right_total,tok) :: !pp_scan_stack
(*
To open a new block :
the user may set the depth bound pp_max_boxes
any text nested deeper is printed as the character the ellipsis
*)
let pp_open_box (indent,br_ty) =
incr pp_curr_depth;
if !pp_curr_depth < !pp_max_boxes then
(scan_push false
{elem_size = (- !pp_right_total);
token = Pp_begin (indent, br_ty); length = 0}) else
if !pp_curr_depth = !pp_max_boxes then enqueue_string !pp_ellipsis
(* The box which is always opened *)
let pp_open_sys_box () =
incr pp_curr_depth;
scan_push false
{elem_size = (- !pp_right_total);
token = Pp_begin (0, Pp_hovbox); length = 0}
(* close a block, setting sizes of its subblocks *)
let close_box () =
if !pp_curr_depth > 1 then
begin
if !pp_curr_depth < !pp_max_boxes then
begin
pp_enqueue {elem_size = 0; token = Pp_end; length = 0};
set_size true; set_size false
end;
decr pp_curr_depth
end
(* Initialize pretty-printer. *)
let pp_rinit () =
pp_clear_queue ();
clear_scan_stack();
pp_current_indent := 0;
pp_curr_depth := 0; pp_space_left := !pp_margin;
pp_format_stack := [];
pp_tbox_stack := [];
pp_open_sys_box ()
(* Flushing pretty-printer queue. *)
let pp_flush b =
while !pp_curr_depth > 1 do
close_box ()
done;
pp_right_total := pp_infinity; advance_left ();
if b then pp_output_newline ();
current_output.flush_function ();
pp_rinit()
(**************************************************************
Procedures to format objects, and use boxes
**************************************************************)
(* To format a string *)
let print_as n s =
if !pp_curr_depth < !pp_max_boxes then (enqueue_string_as n s)
let print_string s = print_as (String.length s) s
(* To format an integer *)
let print_int i = print_string (string_of_int i)
(* To format a float *)
let print_float f = print_string (string_of_float f)
(* To format a boolean *)
let print_bool b = print_string (string_of_bool b)
(* To format a char *)
let print_char c = print_string (String.make 1 c)
let open_hbox () = pp_open_box (0, Pp_hbox)
and open_vbox indent = pp_open_box (indent, Pp_vbox)
and open_hvbox indent = pp_open_box (indent, Pp_hvbox)
and open_hovbox indent = pp_open_box (indent, Pp_hovbox)
(* Print a new line after printing all queued text
(same for print_flush but without a newline) *)
let print_newline () = pp_flush true
and print_flush () = pp_flush false
(* To get a newline when one does not want to close the current block *)
let force_newline () =
if !pp_curr_depth < !pp_max_boxes
then enqueue_advance {elem_size = 0; token = Pp_newline; length = 0}
(* To format something if the line has just been broken *)
let print_if_newline () =
if !pp_curr_depth < !pp_max_boxes
then enqueue_advance {elem_size = 0; token = Pp_if_newline ;length = 0}
(* Breaks: indicate where a block may be broken.
If line is broken then offset is added to the indentation of the current
block else (the value of) width blanks are printed.
To do (?) : add a maximum width and offset value *)
let print_break width offset =
if !pp_curr_depth < !pp_max_boxes then
scan_push true
{elem_size = (- !pp_right_total); token = Pp_break (width,offset);
length = width}
let print_space () = print_break 1 0
and print_cut () = print_break 0 0
let open_tbox () =
incr pp_curr_depth;
if !pp_curr_depth < !pp_max_boxes then
enqueue_advance
{elem_size = 0;
token = Pp_tbegin (Pp_tbox (ref [])); length = 0}
(* Close a tabulation block *)
let close_tbox () =
if !pp_curr_depth > 1 then begin
if !pp_curr_depth < !pp_max_boxes then
enqueue_advance {elem_size = 0; token = Pp_tend; length = 0};
decr pp_curr_depth end
(* Print a tabulation break *)
let print_tbreak width offset =
if !pp_curr_depth < !pp_max_boxes then
scan_push true
{elem_size = (- !pp_right_total); token = Pp_tbreak (width,offset);
length = width}
let print_tab () = print_tbreak 0 0
let set_tab () =
if !pp_curr_depth < !pp_max_boxes
then enqueue_advance {elem_size = 0; token = Pp_stab; length=0}
(**************************************************************
Procedures to control the pretty-printer
**************************************************************)
(* Fit max_boxes *)
let set_max_boxes n = if n > 1 then pp_max_boxes := n
(* To know the current maximum number of boxes allowed *)
let get_max_boxes () = !pp_max_boxes
(* Ellipsis *)
let set_ellipsis_text s = pp_ellipsis := s
and get_ellipsis_text () = !pp_ellipsis
(* To set the margin of pretty-formater *)
let set_min_space_left n =
if n >= 1 then
begin
pp_min_space_left := n;
pp_max_indent := !pp_margin - !pp_min_space_left;
pp_rinit () end
let set_max_indent n = set_min_space_left (!pp_margin - n)
let get_max_indent () = !pp_max_indent
let set_margin n =
if n >= 1 then
begin
pp_margin := n;
let new_max_indent =
(* Try to maintain max_indent to its actual val *)
if !pp_max_indent <= !pp_margin then !pp_max_indent else
(* If possible maintain pp_min_space_left to its actual val,
if this leads to a too small max_indent, take half of the
new margin, if it is greater than 1 *)
max (max (!pp_margin - !pp_min_space_left) (!pp_margin / 2)) 1 in
(* Rebuild invariants *)
set_max_indent new_max_indent;
pp_rinit () end
let get_margin () = !pp_margin
let set_formatter_output_functions f =
current_output.output_function <- f.output_function;
current_output.flush_function <- f.flush_function
let get_formatter_output_functions () =
{ output_function = current_output.output_function;
flush_function = current_output.flush_function }
let set_formatter_output os =
current_output.output_function <- output os;
current_output.flush_function <- (fun () -> flush os)
(* Initialize the formatter *)
let _ = pp_rinit(); at_exit print_flush