diff options
Diffstat (limited to 'tests/examplefiles/format.ml')
| -rw-r--r-- | tests/examplefiles/format.ml | 1213 |
1 files changed, 0 insertions, 1213 deletions
diff --git a/tests/examplefiles/format.ml b/tests/examplefiles/format.ml deleted file mode 100644 index 49b40678..00000000 --- a/tests/examplefiles/format.ml +++ /dev/null @@ -1,1213 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: format.ml,v 1.65 2005/09/26 10:13:08 weis Exp $ *) - -(************************************************************** - - Data structures definitions. - - **************************************************************) - -type size;; - -external size_of_int : int -> size = "%identity";; -external int_of_size : size -> int = "%identity";; - -(* 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 tabulation *) -| 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 *) -| Pp_open_tag of string (* opening a tag name *) -| Pp_close_tag (* closing the most recently opened tag *) - -and tag = string - -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_box (* Horizontal or Indent block: breaks lead to new line - only when necessary to print the content of the block, or - when it leads to a new indentation of the current line *) -| 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 : size; 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;; - -(* 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;; - -(* General purpose queues, used in the formatter. *) -type 'a queue_elem = | Nil | Cons of 'a queue_cell -and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};; - -type 'a queue = { - mutable insert : 'a queue_elem; - mutable body : 'a queue_elem -};; - -(* The formatter specific tag handling functions. *) -type formatter_tag_functions = { - mark_open_tag : tag -> string; - mark_close_tag : tag -> string; - print_open_tag : tag -> unit; - print_close_tag : tag -> unit; - -};; - -(* A formatter with all its machinery. *) -type formatter = { - mutable pp_scan_stack : pp_scan_elem list; - mutable pp_format_stack : pp_format_elem list; - mutable pp_tbox_stack : tblock list; - mutable pp_tag_stack : tag list; - mutable pp_mark_stack : tag list; - (* Global variables: default initialization is - set_margin 78 - set_min_space_left 0. *) - (* Value of right margin. *) - mutable pp_margin : int; - (* Minimal space left before margin, when opening a block. *) - mutable pp_min_space_left : int; - (* Maximum value of indentation: - no blocks can be opened further. *) - mutable pp_max_indent : int; - (* Space remaining on the current line. *) - mutable pp_space_left : int; - (* Current value of indentation. *) - mutable pp_current_indent : int; - (* True when the line has been broken by the pretty-printer. *) - mutable pp_is_new_line : bool; - (* Total width of tokens already printed. *) - mutable pp_left_total : int; - (* Total width of tokens ever put in queue. *) - mutable pp_right_total : int; - (* Current number of opened blocks. *) - mutable pp_curr_depth : int; - (* Maximum number of blocks which can be simultaneously opened. *) - mutable pp_max_boxes : int; - (* Ellipsis string. *) - mutable pp_ellipsis : string; - (* Output function. *) - mutable pp_output_function : string -> int -> int -> unit; - (* Flushing function. *) - mutable pp_flush_function : unit -> unit; - (* Output of new lines. *) - mutable pp_output_newline : unit -> unit; - (* Output of indentation spaces. *) - mutable pp_output_spaces : int -> unit; - (* Are tags printed ? *) - mutable pp_print_tags : bool; - (* Are tags marked ? *) - mutable pp_mark_tags : bool; - (* Find opening and closing markers of tags. *) - mutable pp_mark_open_tag : tag -> string; - mutable pp_mark_close_tag : tag -> string; - mutable pp_print_open_tag : tag -> unit; - mutable pp_print_close_tag : tag -> unit; - (* The pretty-printer queue. *) - mutable pp_queue : pp_queue_elem queue -};; - -(************************************************************** - - Auxilliaries and basic functions. - - **************************************************************) - - -(* Queues auxilliaries. *) -let make_queue () = {insert = Nil; body = Nil};; - -let clear_queue q = q.insert <- Nil; q.body <- Nil;; - -let add_queue x q = - let c = Cons {head = x; tail = Nil} in - match q with - | {insert = Cons cell} -> q.insert <- c; cell.tail <- c - (* Invariant: when insert is Nil body should be Nil. *) - | _ -> q.insert <- c; q.body <- c;; - -exception Empty_queue;; - -let peek_queue = function - | {body = Cons {head = x}} -> x - | _ -> raise Empty_queue;; - -let take_queue = function - | {body = Cons {head = x; tail = tl}} as q -> - q.body <- tl; - if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) - x - | _ -> raise Empty_queue;; - -(* Enter a token in the pretty-printer queue. *) -let pp_enqueue state ({length = len} as token) = - state.pp_right_total <- state.pp_right_total + len; - add_queue token state.pp_queue;; - -let pp_clear_queue state = - state.pp_left_total <- 1; state.pp_right_total <- 1; - clear_queue state.pp_queue;; - -(* Pp_infinity: large value for default tokens size. - - Pp_infinity is documented as being greater than 1e10; to avoid - confusion about the word ``greater'', we choose pp_infinity greater - than 1e10 + 1; for correct handling of tests in the algorithm, - pp_infinity must be even one more than 1e10 + 1; let's stand on the - safe side by choosing 1.e10+10. - - Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is - the minimal upper bound for integers; now that max_int is defined, - this limit could also be defined as max_int - 1. - - However, before setting pp_infinity to something around max_int, we - must carefully double-check all the integer arithmetic operations - that involve pp_infinity, since any overflow would wreck havoc the - pretty-printing algorithm's invariants. Given that this arithmetic - correctness check is difficult and error prone and given that 1e10 - + 1 is in practice large enough, there is no need to attempt to set - pp_infinity to the theoretically maximum limit. Is it not worth the - burden ! *) - -let pp_infinity = 1000000010;; - -(* Output functions for the formatter. *) -let pp_output_string state s = state.pp_output_function s 0 (String.length s) -and pp_output_newline state = state.pp_output_newline ();; - -let pp_display_blanks state n = state.pp_output_spaces n;; - -(* To format a break, indenting a new line. *) -let break_new_line state offset width = - pp_output_newline state; - state.pp_is_new_line <- true; - let indent = state.pp_margin - width + offset in - (* Don't indent more than pp_max_indent. *) - let real_indent = min state.pp_max_indent indent in - state.pp_current_indent <- real_indent; - state.pp_space_left <- state.pp_margin - state.pp_current_indent; - pp_display_blanks state state.pp_current_indent;; - -(* To force a line break inside a block: no offset is added. *) -let break_line state width = break_new_line state 0 width;; - -(* To format a break that fits on the current line. *) -let break_same_line state width = - state.pp_space_left <- state.pp_space_left - width; - pp_display_blanks state 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_break_line state = - match state.pp_format_stack with - | Format_elem (bl_ty, width) :: _ -> - if width > state.pp_space_left then - (match bl_ty with - | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) - | _ -> pp_output_newline state;; - -(* To skip a token, if the previous line has been broken. *) -let pp_skip_token state = - (* When calling pp_skip_token the queue cannot be empty. *) - match take_queue state.pp_queue with - {elem_size = size; length = len} -> - state.pp_left_total <- state.pp_left_total - len; - state.pp_space_left <- state.pp_space_left + int_of_size size;; - -(************************************************************** - - The main pretting printing functions. - - **************************************************************) - -(* To format a token. *) -let format_pp_token state size = function - - | Pp_text s -> - state.pp_space_left <- state.pp_space_left - size; - pp_output_string state s; - state.pp_is_new_line <- false - - | Pp_begin (off, ty) -> - let insertion_point = state.pp_margin - state.pp_space_left in - if insertion_point > state.pp_max_indent then - (* can't open a block right there. *) - begin pp_force_break_line state end; - let offset = state.pp_space_left - off in - let bl_type = - begin match ty with - | Pp_vbox -> Pp_vbox - | _ -> if size > state.pp_space_left then ty else Pp_fits - end in - state.pp_format_stack <- - Format_elem (bl_type, offset) :: state.pp_format_stack - - | Pp_end -> - begin match state.pp_format_stack with - | x :: (y :: l as ls) -> state.pp_format_stack <- ls - | _ -> () (* No more block to close. *) - end - - | Pp_tbegin (Pp_tbox _ as tbox) -> - state.pp_tbox_stack <- tbox :: state.pp_tbox_stack - - | Pp_tend -> - begin match state.pp_tbox_stack with - | x :: ls -> state.pp_tbox_stack <- ls - | _ -> () (* No more tabulation block to close. *) - end - - | Pp_stab -> - begin match state.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 (state.pp_margin - state.pp_space_left) !tabs - | _ -> () (* No opened tabulation block. *) - end - - | Pp_tbreak (n, off) -> - let insertion_point = state.pp_margin - state.pp_space_left in - begin match state.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 state (offset + n) else - break_new_line state (tab + off) state.pp_margin - | _ -> () (* No opened tabulation block. *) - end - - | Pp_newline -> - begin match state.pp_format_stack with - | Format_elem (_, width) :: _ -> break_line state width - | _ -> pp_output_newline state - end - - | Pp_if_newline -> - if state.pp_current_indent != state.pp_margin - state.pp_space_left - then pp_skip_token state - - | Pp_break (n, off) -> - begin match state.pp_format_stack with - | Format_elem (ty, width) :: _ -> - begin match ty with - | Pp_hovbox -> - if size > state.pp_space_left - then break_new_line state off width - else break_same_line state n - | Pp_box -> - (* Have the line just been broken here ? *) - if state.pp_is_new_line then break_same_line state n else - if size > state.pp_space_left - then break_new_line state off width else - (* break the line here leads to new indentation ? *) - if state.pp_current_indent > state.pp_margin - width + off - then break_new_line state off width - else break_same_line state n - | Pp_hvbox -> break_new_line state off width - | Pp_fits -> break_same_line state n - | Pp_vbox -> break_new_line state off width - | Pp_hbox -> break_same_line state n - end - | _ -> () (* No opened block. *) - end - - | Pp_open_tag tag_name -> - let marker = state.pp_mark_open_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tag_name :: state.pp_mark_stack - - | Pp_close_tag -> - begin match state.pp_mark_stack with - | tag_name :: tags -> - let marker = state.pp_mark_close_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tags - | _ -> () (* No more tag to close. *) - 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 exists on the current line. *) -let rec advance_left state = - try - match peek_queue state.pp_queue with - {elem_size = size; token = tok; length = len} -> - let size = int_of_size size in - if not - (size < 0 && - (state.pp_right_total - state.pp_left_total < state.pp_space_left)) - then begin - ignore(take_queue state.pp_queue); - format_pp_token state (if size < 0 then pp_infinity else size) tok; - state.pp_left_total <- len + state.pp_left_total; - advance_left state - end - with Empty_queue -> ();; - -let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; - -(* To enqueue a string : try to advance. *) -let make_queue_elem size tok len = - {elem_size = size; token = tok; length = len};; - -let enqueue_string_as state size s = - let len = int_of_size size in - enqueue_advance state (make_queue_elem size (Pp_text s) len);; - -let enqueue_string state s = - let len = String.length s in - enqueue_string_as state (size_of_int len) s;; - -(* Routines for scan stack - determine sizes of blocks. *) - -(* The scan_stack is never empty. *) -let scan_stack_bottom = - let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in - [Scan_elem (-1, q_elem)];; - -(* 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. *) -let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; - -(* 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 state ty = - match state.pp_scan_stack with - | Scan_elem - (left_tot, - ({elem_size = size; token = tok} as queue_elem)) :: t -> - let size = int_of_size size in - (* test if scan stack contains any data that is not obsolete. *) - if left_tot < state.pp_left_total then clear_scan_stack state else - begin match tok with - | Pp_break (_, _) | Pp_tbreak (_, _) -> - if ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | Pp_begin (_, _) -> - if not ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.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 state b tok = - pp_enqueue state tok; - if b then set_size state true; - state.pp_scan_stack <- - Scan_elem (state.pp_right_total, tok) :: state.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 ellipsis string. *) -let pp_open_box_gen state indent br_ty = - state.pp_curr_depth <- state.pp_curr_depth + 1; - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_begin (indent, br_ty)) - 0 in - scan_push state false elem else - if state.pp_curr_depth = state.pp_max_boxes - then enqueue_string state state.pp_ellipsis;; - -(* The box which is always opened. *) -let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; - -(* Close a block, setting sizes of its subblocks. *) -let pp_close_box state () = - if state.pp_curr_depth > 1 then - begin - if state.pp_curr_depth < state.pp_max_boxes then - begin - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_end; length = 0}; - set_size state true; set_size state false - end; - state.pp_curr_depth <- state.pp_curr_depth - 1; - end;; - -(* Open a tag, pushing it on the tag stack. *) -let pp_open_tag state tag_name = - if state.pp_print_tags then begin - state.pp_tag_stack <- tag_name :: state.pp_tag_stack; - state.pp_print_open_tag tag_name end; - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};; - -(* Close a tag, popping it from the tag stack. *) -let pp_close_tag state () = - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_close_tag; length = 0}; - if state.pp_print_tags then - begin match state.pp_tag_stack with - | tag_name :: tags -> - state.pp_print_close_tag tag_name; - state.pp_tag_stack <- tags - | _ -> () (* No more tag to close. *) - end;; - -let pp_set_print_tags state b = state.pp_print_tags <- b;; -let pp_set_mark_tags state b = state.pp_mark_tags <- b;; -let pp_get_print_tags state () = state.pp_print_tags;; -let pp_get_mark_tags state () = state.pp_mark_tags;; -let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; - -let pp_get_formatter_tag_functions state () = { - mark_open_tag = state.pp_mark_open_tag; - mark_close_tag = state.pp_mark_close_tag; - print_open_tag = state.pp_print_open_tag; - print_close_tag = state.pp_print_close_tag; -};; - -let pp_set_formatter_tag_functions state { - mark_open_tag = mot; - mark_close_tag = mct; - print_open_tag = pot; - print_close_tag = pct; - } = - state.pp_mark_open_tag <- mot; - state.pp_mark_close_tag <- mct; - state.pp_print_open_tag <- pot; - state.pp_print_close_tag <- pct;; - -(* Initialize pretty-printer. *) -let pp_rinit state = - pp_clear_queue state; - clear_scan_stack state; - state.pp_format_stack <- []; - state.pp_tbox_stack <- []; - state.pp_tag_stack <- []; - state.pp_mark_stack <- []; - state.pp_current_indent <- 0; - state.pp_curr_depth <- 0; - state.pp_space_left <- state.pp_margin; - pp_open_sys_box state;; - -(* Flushing pretty-printer queue. *) -let pp_flush_queue state b = - while state.pp_curr_depth > 1 do - pp_close_box state () - done; - state.pp_right_total <- pp_infinity; - advance_left state; - if b then pp_output_newline state; - pp_rinit state;; - -(************************************************************** - - Procedures to format objects, and use boxes - - **************************************************************) - -(* To format a string. *) -let pp_print_as_size state size s = - if state.pp_curr_depth < state.pp_max_boxes - then enqueue_string_as state size s;; - -let pp_print_as state isize s = - pp_print_as_size state (size_of_int isize) s;; - -let pp_print_string state s = - pp_print_as state (String.length s) s;; - -(* To format an integer. *) -let pp_print_int state i = pp_print_string state (string_of_int i);; - -(* To format a float. *) -let pp_print_float state f = pp_print_string state (string_of_float f);; - -(* To format a boolean. *) -let pp_print_bool state b = pp_print_string state (string_of_bool b);; - -(* To format a char. *) -let pp_print_char state c = - let s = String.create 1 in - s.[0] <- c; - pp_print_as state 1 s;; - -(* Opening boxes. *) -let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox -and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox - -and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox -and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox -and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; - -(* Print a new line after printing all queued text - (same for print_flush but without a newline). *) -let pp_print_newline state () = - pp_flush_queue state true; state.pp_flush_function () -and pp_print_flush state () = - pp_flush_queue state false; state.pp_flush_function ();; - -(* To get a newline when one does not want to close the current block. *) -let pp_force_newline state () = - if state.pp_curr_depth < state.pp_max_boxes then - enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0);; - -(* To format something if the line has just been broken. *) -let pp_print_if_newline state () = - if state.pp_curr_depth < state.pp_max_boxes then - enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 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 pp_print_break state width offset = - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_break (width, offset)) - width in - scan_push state true elem;; - -let pp_print_space state () = pp_print_break state 1 0 -and pp_print_cut state () = pp_print_break state 0 0;; - -(* Tabulation boxes. *) -let pp_open_tbox state () = - state.pp_curr_depth <- state.pp_curr_depth + 1; - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in - enqueue_advance state elem;; - -(* Close a tabulation block. *) -let pp_close_tbox state () = - if state.pp_curr_depth > 1 then begin - if state.pp_curr_depth < state.pp_max_boxes then - let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in - enqueue_advance state elem; - state.pp_curr_depth <- state.pp_curr_depth - 1 end;; - -(* Print a tabulation break. *) -let pp_print_tbreak state width offset = - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_tbreak (width, offset)) - width in - scan_push state true elem;; - -let pp_print_tab state () = pp_print_tbreak state 0 0;; - -let pp_set_tab state () = - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem (size_of_int 0) Pp_stab 0 in - enqueue_advance state elem;; - -(************************************************************** - - Procedures to control the pretty-printers - - **************************************************************) - -(* Fit max_boxes. *) -let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;; - -(* To know the current maximum number of boxes allowed. *) -let pp_get_max_boxes state () = state.pp_max_boxes;; - -let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; - -(* Ellipsis. *) -let pp_set_ellipsis_text state s = state.pp_ellipsis <- s -and pp_get_ellipsis_text state () = state.pp_ellipsis;; - -(* To set the margin of pretty-printer. *) -let pp_limit n = - if n < pp_infinity then n else pred pp_infinity;; - -let pp_set_min_space_left state n = - if n >= 1 then - let n = pp_limit n in - state.pp_min_space_left <- n; - state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; - pp_rinit state;; - -(* Initially, we have : - pp_max_indent = pp_margin - pp_min_space_left, and - pp_space_left = pp_margin. *) -let pp_set_max_indent state n = - pp_set_min_space_left state (state.pp_margin - n);; -let pp_get_max_indent state () = state.pp_max_indent;; - -let pp_set_margin state n = - if n >= 1 then - let n = pp_limit n in - state.pp_margin <- n; - let new_max_indent = - (* Try to maintain max_indent to its actual value. *) - if state.pp_max_indent <= state.pp_margin - then state.pp_max_indent else - (* If possible maintain pp_min_space_left to its actual value, - if this leads to a too small max_indent, take half of the - new margin, if it is greater than 1. *) - max (max (state.pp_margin - state.pp_min_space_left) - (state.pp_margin / 2)) 1 in - (* Rebuild invariants. *) - pp_set_max_indent state new_max_indent;; - -let pp_get_margin state () = state.pp_margin;; - -let pp_set_formatter_output_functions state f g = - state.pp_output_function <- f; state.pp_flush_function <- g;; -let pp_get_formatter_output_functions state () = - (state.pp_output_function, state.pp_flush_function);; - -let pp_set_all_formatter_output_functions state - ~out:f ~flush:g ~newline:h ~spaces:i = - pp_set_formatter_output_functions state f g; - state.pp_output_newline <- (function () -> h ()); - state.pp_output_spaces <- (function n -> i n);; -let pp_get_all_formatter_output_functions state () = - (state.pp_output_function, state.pp_flush_function, - state.pp_output_newline, state.pp_output_spaces);; - -let pp_set_formatter_out_channel state os = - state.pp_output_function <- output os; - state.pp_flush_function <- (fun () -> flush os);; - -(************************************************************** - - Creation of specific formatters - - **************************************************************) - -let default_pp_mark_open_tag s = "<" ^ s ^ ">";; -let default_pp_mark_close_tag s = "</" ^ s ^ ">";; - -let default_pp_print_open_tag s = ();; -let default_pp_print_close_tag = default_pp_print_open_tag;; - -let pp_make_formatter f g h i = - (* The initial state of the formatter contains a dummy box. *) - let pp_q = make_queue () in - let sys_tok = - make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in - add_queue sys_tok pp_q; - let sys_scan_stack = - (Scan_elem (1, sys_tok)) :: scan_stack_bottom in - {pp_scan_stack = sys_scan_stack; - pp_format_stack = []; - pp_tbox_stack = []; - pp_tag_stack = []; - pp_mark_stack = []; - pp_margin = 78; - pp_min_space_left = 10; - pp_max_indent = 78 - 10; - pp_space_left = 78; - pp_current_indent = 0; - pp_is_new_line = true; - pp_left_total = 1; - pp_right_total = 1; - pp_curr_depth = 1; - pp_max_boxes = max_int; - pp_ellipsis = "."; - pp_output_function = f; - pp_flush_function = g; - pp_output_newline = h; - pp_output_spaces = i; - pp_print_tags = false; - pp_mark_tags = false; - pp_mark_open_tag = default_pp_mark_open_tag; - pp_mark_close_tag = default_pp_mark_close_tag; - pp_print_open_tag = default_pp_print_open_tag; - pp_print_close_tag = default_pp_print_close_tag; - pp_queue = pp_q - };; - -(* Default function to output spaces. *) -let blank_line = String.make 80 ' ';; -let rec display_blanks state n = - if n > 0 then - if n <= 80 then state.pp_output_function blank_line 0 n else - begin - state.pp_output_function blank_line 0 80; - display_blanks state (n - 80) - end;; - -(* Default function to output new lines. *) -let display_newline state () = state.pp_output_function "\n" 0 1;; - -let make_formatter f g = - let ff = pp_make_formatter f g ignore ignore in - ff.pp_output_newline <- display_newline ff; - ff.pp_output_spaces <- display_blanks ff; - ff;; - -let formatter_of_out_channel oc = - make_formatter (output oc) (fun () -> flush oc);; - -let formatter_of_buffer b = - make_formatter (Buffer.add_substring b) ignore;; - -let stdbuf = Buffer.create 512;; - -let str_formatter = formatter_of_buffer stdbuf;; -let std_formatter = formatter_of_out_channel stdout;; -let err_formatter = formatter_of_out_channel stderr;; - -let flush_str_formatter () = - pp_flush_queue str_formatter false; - let s = Buffer.contents stdbuf in - Buffer.reset stdbuf; - s;; - -(************************************************************** - - Basic functions on the standard formatter - - **************************************************************) - -let open_hbox = pp_open_hbox std_formatter -and open_vbox = pp_open_vbox std_formatter -and open_hvbox = pp_open_hvbox std_formatter -and open_hovbox = pp_open_hovbox std_formatter -and open_box = pp_open_box std_formatter -and close_box = pp_close_box std_formatter -and open_tag = pp_open_tag std_formatter -and close_tag = pp_close_tag std_formatter -and print_as = pp_print_as std_formatter -and print_string = pp_print_string std_formatter -and print_int = pp_print_int std_formatter -and print_float = pp_print_float std_formatter -and print_char = pp_print_char std_formatter -and print_bool = pp_print_bool std_formatter -and print_break = pp_print_break std_formatter -and print_cut = pp_print_cut std_formatter -and print_space = pp_print_space std_formatter -and force_newline = pp_force_newline std_formatter -and print_flush = pp_print_flush std_formatter -and print_newline = pp_print_newline std_formatter -and print_if_newline = pp_print_if_newline std_formatter - -and open_tbox = pp_open_tbox std_formatter -and close_tbox = pp_close_tbox std_formatter -and print_tbreak = pp_print_tbreak std_formatter - -and set_tab = pp_set_tab std_formatter -and print_tab = pp_print_tab std_formatter - -and set_margin = pp_set_margin std_formatter -and get_margin = pp_get_margin std_formatter - -and set_max_indent = pp_set_max_indent std_formatter -and get_max_indent = pp_get_max_indent std_formatter - -and set_max_boxes = pp_set_max_boxes std_formatter -and get_max_boxes = pp_get_max_boxes std_formatter -and over_max_boxes = pp_over_max_boxes std_formatter - -and set_ellipsis_text = pp_set_ellipsis_text std_formatter -and get_ellipsis_text = pp_get_ellipsis_text std_formatter - -and set_formatter_out_channel = - pp_set_formatter_out_channel std_formatter - -and set_formatter_output_functions = - pp_set_formatter_output_functions std_formatter -and get_formatter_output_functions = - pp_get_formatter_output_functions std_formatter - -and set_all_formatter_output_functions = - pp_set_all_formatter_output_functions std_formatter -and get_all_formatter_output_functions = - pp_get_all_formatter_output_functions std_formatter - -and set_formatter_tag_functions = - pp_set_formatter_tag_functions std_formatter -and get_formatter_tag_functions = - pp_get_formatter_tag_functions std_formatter -and set_print_tags = - pp_set_print_tags std_formatter -and get_print_tags = - pp_get_print_tags std_formatter -and set_mark_tags = - pp_set_mark_tags std_formatter -and get_mark_tags = - pp_get_mark_tags std_formatter -and set_tags = - pp_set_tags std_formatter -;; - - -(************************************************************** - - Printf implementation. - - **************************************************************) - -(* Error messages when processing formats. *) - -(* Trailer: giving up at character number ... *) -let giving_up mess fmt i = - "fprintf: " ^ mess ^ " ``" ^ fmt ^ "'', \ - giving up at character number " ^ string_of_int i ^ - (if i < String.length fmt - then " (" ^ String.make 1 fmt.[i] ^ ")." - else String.make 1 '.');; - -(* When an invalid format deserves a special error explanation. *) -let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; - -(* Standard invalid format. *) -let invalid_format fmt i = format_invalid_arg "bad format" fmt i;; - -(* Cannot find a valid integer into that format. *) -let invalid_integer fmt i = - invalid_arg (giving_up "bad integer specification" fmt i);; - -(* Finding an integer out of a sub-string of the format. *) -let format_int_of_string fmt i s = - let sz = - try int_of_string s with - | Failure s -> invalid_integer fmt i in - size_of_int sz;; - -(* Getting strings out of buffers. *) -let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s;; - -(* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]: - to extract contents of [ppf] as a string we flush [ppf] and get the string - out of [b]. *) -let string_out b ppf = - pp_flush_queue ppf false; - get_buffer_out b;; - -(* Applies [printer] to a formatter that outputs on a fresh buffer, - then returns the resulting material. *) -let exstring printer arg = - let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in - printer ppf arg; - string_out b ppf;; - -(* To turn out a character accumulator into the proper string result. *) -let implode_rev s0 = function - | [] -> s0 - | l -> String.concat "" (List.rev (s0 :: l));; - -external format_to_string : ('a, 'b, 'c, 'd) format4 -> string = "%identity";; - -(* [fprintf_out] is the printf-like function generator: given the - - [str] flag that tells if we are printing into a string, - - the [out] function that has to be called at the end of formatting, - it generates a [fprintf] function that takes as arguments a [ppf] - formatter and a printing format to print the rest of arguments - according to the format. - Regular [fprintf]-like functions of this module are obtained via partial - applications of [fprintf_out]. *) -let mkprintf str get_out = - let rec kprintf k fmt = - let fmt = format_to_string fmt in - let len = String.length fmt in - - let kpr fmt v = - let ppf = get_out fmt in - let print_as = ref None in - let pp_print_as_char c = - match !print_as with - | None -> pp_print_char ppf c - | Some size -> - pp_print_as_size ppf size (String.make 1 c); - print_as := None - and pp_print_as_string s = - match !print_as with - | None -> pp_print_string ppf s - | Some size -> - pp_print_as_size ppf size s; - print_as := None in - - let rec doprn n i = - if i >= len then Obj.magic (k ppf) else - match fmt.[i] with - | '%' -> - Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | '@' -> - let i = succ i in - if i >= len then invalid_format fmt i else - begin match fmt.[i] with - | '[' -> - do_pp_open_box ppf n (succ i) - | ']' -> - pp_close_box ppf (); - doprn n (succ i) - | '{' -> - do_pp_open_tag ppf n (succ i) - | '}' -> - pp_close_tag ppf (); - doprn n (succ i) - | ' ' -> - pp_print_space ppf (); - doprn n (succ i) - | ',' -> - pp_print_cut ppf (); - doprn n (succ i) - | '?' -> - pp_print_flush ppf (); - doprn n (succ i) - | '.' -> - pp_print_newline ppf (); - doprn n (succ i) - | '\n' -> - pp_force_newline ppf (); - doprn n (succ i) - | ';' -> - do_pp_break ppf n (succ i) - | '<' -> - let got_size size n i = - print_as := Some size; - doprn n (skip_gt i) in - get_int n (succ i) got_size - | '@' as c -> - pp_print_as_char c; - doprn n (succ i) - | c -> invalid_format fmt i - end - | c -> - pp_print_as_char c; - doprn n (succ i) - - and cont_s n s i = - pp_print_as_string s; doprn n i - and cont_a n printer arg i = - if str then - pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) - else - printer ppf arg; - doprn n i - and cont_t n printer i = - if str then - pp_print_as_string ((Obj.magic printer : unit -> string) ()) - else - printer ppf; - doprn n i - and cont_f n i = - pp_print_flush ppf (); doprn n i - - and cont_m n sfmt i = - kprintf (Obj.magic (fun _ -> doprn n i)) sfmt - - and get_int n i c = - if i >= len then invalid_integer fmt i else - match fmt.[i] with - | ' ' -> get_int n (succ i) c - | '%' -> - let cont_s n s i = c (format_int_of_string fmt i s) n i - and cont_a n printer arg i = invalid_integer fmt i - and cont_t n printer i = invalid_integer fmt i - and cont_f n i = invalid_integer fmt i - and cont_m n sfmt i = invalid_integer fmt i in - Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | _ -> - let rec get j = - if j >= len then invalid_integer fmt j else - match fmt.[j] with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else - format_int_of_string fmt j (String.sub fmt i (j - i)) in - c size n j in - get i - - and skip_gt i = - if i >= len then invalid_format fmt i else - match fmt.[i] with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i - - and get_box_kind i = - if i >= len then Pp_box, i else - match fmt.[i] with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match fmt.[i] with - | 'o' -> - let i = succ i in - if i >= len then format_invalid_arg "bad box format" fmt i else - begin match fmt.[i] with - | 'v' -> Pp_hovbox, succ i - | c -> - format_invalid_arg - ("bad box name ho" ^ String.make 1 c) fmt i end - | 'v' -> Pp_hvbox, succ i - | c -> Pp_hbox, i - end - | 'b' -> Pp_box, succ i - | 'v' -> Pp_vbox, succ i - | _ -> Pp_box, i - - and get_tag_name n i c = - let rec get accu n i j = - if j >= len - then c (implode_rev (String.sub fmt i (j - i)) accu) n j else - match fmt.[j] with - | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) n j - | '%' -> - let s0 = String.sub fmt i (j - i) in - let cont_s n s i = get (s :: s0 :: accu) n i i - and cont_a n printer arg i = - let s = - if str - then (Obj.magic printer : unit -> _ -> string) () arg - else exstring printer arg in - get (s :: s0 :: accu) n i i - and cont_t n printer i = - let s = - if str - then (Obj.magic printer : unit -> string) () - else exstring (fun ppf () -> printer ppf) () in - get (s :: s0 :: accu) n i i - and cont_f n i = - format_invalid_arg "bad tag name specification" fmt i - and cont_m n sfmt i = - format_invalid_arg "bad tag name specification" fmt i in - Printf.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m - | c -> get accu n i (succ j) in - get [] n i i - - and do_pp_break ppf n i = - if i >= len then begin pp_print_space ppf (); doprn n i end else - match fmt.[i] with - | '<' -> - let rec got_nspaces nspaces n i = - get_int n i (got_offset nspaces) - and got_offset nspaces offset n i = - pp_print_break ppf (int_of_size nspaces) (int_of_size offset); - doprn n (skip_gt i) in - get_int n (succ i) got_nspaces - | c -> pp_print_space ppf (); doprn n i - - and do_pp_open_box ppf n i = - if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match fmt.[i] with - | '<' -> - let kind, i = get_box_kind (succ i) in - let got_size size n i = - pp_open_box_gen ppf (int_of_size size) kind; - doprn n (skip_gt i) in - get_int n i got_size - | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i - - and do_pp_open_tag ppf n i = - if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match fmt.[i] with - | '<' -> - let got_name tag_name n i = - pp_open_tag ppf tag_name; - doprn n (skip_gt i) in - get_tag_name n (succ i) got_name - | c -> pp_open_tag ppf ""; doprn n i in - - doprn (Printf.index_of_int 0) 0 in - - Printf.kapr kpr fmt in - - kprintf;; - -(************************************************************** - - Defining [fprintf] and various flavors of [fprintf]. - - **************************************************************) - -let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; - -let fprintf ppf = kfprintf ignore ppf;; -let printf fmt = fprintf std_formatter fmt;; -let eprintf fmt = fprintf err_formatter fmt;; - -let kbprintf k b = - mkprintf false (fun _ -> formatter_of_buffer b) k;; - -let bprintf b = kbprintf ignore b;; - -let ksprintf k = - let b = Buffer.create 512 in - let k ppf = k (string_out b ppf) in - mkprintf true (fun _ -> formatter_of_buffer b) k;; - -let kprintf = ksprintf;; - -let sprintf fmt = ksprintf (fun s -> s) fmt;; - -at_exit print_flush;; |