diff options
Diffstat (limited to 'stdlib/format.ml')
| -rw-r--r-- | stdlib/format.ml | 1008 |
1 files changed, 522 insertions, 486 deletions
diff --git a/stdlib/format.ml b/stdlib/format.ml index ca31832e89..6debd39d04 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -64,7 +64,9 @@ and tblock = Pp_tbox of int list ref (* Tabulation box *) 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 + mutable elem_size : size; + token : pp_token; + length : int; };; (* Scan stack: @@ -79,75 +81,80 @@ type pp_scan_elem = Scan_elem of int * pp_queue_elem;; 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_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 + 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; - + 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 + 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; };; (************************************************************** @@ -158,38 +165,39 @@ type formatter = { (* Queues auxilliaries. *) -let make_queue () = {insert = Nil; body = Nil};; +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;; + 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;; + | { body = Cons { head = x; }; } -> x + | _ -> raise Empty_queue;; let take_queue = function - | {body = Cons {head = x; tail = tl}} as q -> + | { 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;; + | _ -> 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;; + 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;; + state.pp_left_total <- 1; state.pp_right_total <- 1; + clear_queue state.pp_queue;; (* Pp_infinity: large value for default tokens size. @@ -216,47 +224,48 @@ 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;; +and pp_output_newline state = state.pp_output_newline () +and 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;; + 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;; + 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;; + 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;; + (* 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;; (************************************************************** @@ -268,141 +277,147 @@ let pp_skip_token state = 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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;; + 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 -> ();; + 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};; + { elem_size = size; token = tok; length = len; };; let enqueue_string_as state size s = let len = int_of_size size in @@ -430,89 +445,99 @@ let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; 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. *) + 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_stack is never empty. *);; + | _ -> () (* 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;; + 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;; + 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;; + 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};; + 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;; + 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;; @@ -521,10 +546,10 @@ 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; + 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 { @@ -540,26 +565,26 @@ let pp_set_formatter_tag_functions state { (* 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;; + 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;; + 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;; (************************************************************** @@ -604,9 +629,9 @@ 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 () + pp_flush_queue state true; state.pp_flush_function () and pp_print_flush state () = - pp_flush_queue state false; state.pp_flush_function ();; + 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 () = @@ -644,11 +669,13 @@ let pp_open_tbox state () = (* Close a tabulation block. *) let pp_close_tbox state () = - if state.pp_curr_depth > 1 then begin + 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;; + state.pp_curr_depth <- state.pp_curr_depth - 1 + end;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = @@ -709,15 +736,15 @@ let pp_set_margin state n = 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. *) + (* 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;; @@ -753,51 +780,51 @@ 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 - };; + (* 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;; + 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;; @@ -816,9 +843,9 @@ let formatter_of_buffer b = 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 str_formatter = formatter_of_buffer stdbuf +and std_formatter = formatter_of_out_channel stdout +and err_formatter = formatter_of_out_channel stderr;; let flush_str_formatter () = pp_flush_queue str_formatter false; @@ -875,32 +902,32 @@ 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 + pp_set_formatter_out_channel std_formatter and set_formatter_output_functions = - pp_set_formatter_output_functions std_formatter + pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = - pp_get_formatter_output_functions std_formatter + pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = - pp_set_all_formatter_output_functions std_formatter + pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = - pp_get_all_formatter_output_functions std_formatter + pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = - pp_set_formatter_tag_functions std_formatter + pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = - pp_get_formatter_tag_functions std_formatter + pp_get_formatter_tag_functions std_formatter and set_print_tags = - pp_set_print_tags std_formatter + pp_set_print_tags std_formatter and get_print_tags = - pp_get_print_tags std_formatter + pp_get_print_tags std_formatter and set_mark_tags = - pp_set_mark_tags std_formatter + pp_set_mark_tags std_formatter and get_mark_tags = - pp_get_mark_tags std_formatter + pp_get_mark_tags std_formatter and set_tags = - pp_set_tags std_formatter + pp_set_tags std_formatter ;; @@ -942,24 +969,24 @@ let format_int_of_string fmt i s = (* Getting strings out of buffers. *) let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s;; + 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;; + 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;; + 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 @@ -979,73 +1006,74 @@ let implode_rev s0 = function let mkprintf to_s get_out = let rec kprintf k fmt = + let len = Sformat.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 + 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 + 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 Sformat.get fmt i with | '%' -> - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.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 Sformat.get 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 + let i = succ i in + if i >= len then invalid_format fmt i else + begin match Sformat.get 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) + pp_print_as_char c; + doprn n (succ i) and cont_s n s i = pp_print_as_string s; doprn n i @@ -1067,123 +1095,131 @@ let mkprintf to_s get_out = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = - if i >= len then invalid_integer fmt i else - match Sformat.get fmt i with - | ' ' -> get_int n (succ i) c - | '%' -> + if i >= len then invalid_integer fmt i else + match Sformat.get 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 Tformat.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 Sformat.get fmt j with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else + if j >= len then invalid_integer fmt j else + match Sformat.get fmt j with + | '0' .. '9' | '-' -> get (succ j) + | _ -> + let size = + if j = i then size_of_int 0 else let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s in - c size n j in + c size n j in get i and skip_gt i = - if i >= len then invalid_format fmt i else - match Sformat.get fmt i with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i + if i >= len then invalid_format fmt i else + match Sformat.get 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 Sformat.get fmt i with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match Sformat.get fmt i with - | 'o' -> + if i >= len then Pp_box, i else + match Sformat.get fmt i with + | 'h' -> + let i = succ i in + if i >= len then Pp_hbox, i else + begin match Sformat.get fmt i with + | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else begin match Sformat.get 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 + 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 (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else - match Sformat.get fmt j with - | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j - | '%' -> - let s0 = Sformat.sub fmt (Sformat.index_of_int 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 to_s - 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 to_s - 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 - Tformat.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 + let rec get accu n i j = + if j >= len then + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j else + match Sformat.get fmt j with + | '>' -> + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j + | '%' -> + let s0 = Sformat.sub fmt (Sformat.index_of_int 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 to_s + 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 to_s + 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 + Tformat.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 Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_print_space ppf (); doprn n i end else + match Sformat.get 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 + | 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 Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else + match Sformat.get 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 + | 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 Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_tag ppf ""; doprn n i end else + match Sformat.get 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 + | c -> pp_open_tag ppf ""; doprn n i in doprn (Sformat.index_of_int 0) 0 in - Tformat.kapr kpr fmt in + Tformat.kapr kpr fmt in kprintf;; |