1(***********************************************************************) 2(* *) 3(* Objective Caml *) 4(* *) 5(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. All rights reserved. This file is distributed *) 9(* under the terms of the GNU Library General Public License, with *) 10(* the special exception on linking described in file ../LICENSE. *) 11(* *) 12(***********************************************************************) 13 14(* $Id: format.ml,v 1.65 2005/09/26 10:13:08 weis Exp $ *) 15 16(************************************************************** 17 18 Data structures definitions. 19 20 **************************************************************) 21 22type size;; 23 24external size_of_int : int -> size = "%identity";; 25external int_of_size : size -> int = "%identity";; 26 27(* Tokens are one of the following : *) 28 29type pp_token = 30| Pp_text of string (* normal text *) 31| Pp_break of int * int (* complete break *) 32| Pp_tbreak of int * int (* go to next tabulation *) 33| Pp_stab (* set a tabulation *) 34| Pp_begin of int * block_type (* beginning of a block *) 35| Pp_end (* end of a block *) 36| Pp_tbegin of tblock (* beginning of a tabulation block *) 37| Pp_tend (* end of a tabulation block *) 38| Pp_newline (* to force a newline inside a block *) 39| Pp_if_newline (* to do something only if this very 40 line has been broken *) 41| Pp_open_tag of string (* opening a tag name *) 42| Pp_close_tag (* closing the most recently opened tag *) 43 44and tag = string 45 46and block_type = 47| Pp_hbox (* Horizontal block no line breaking *) 48| Pp_vbox (* Vertical block each break leads to a new line *) 49| Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block 50 is small enough to fit on a single line *) 51| Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line 52 only when necessary to print the content of the block *) 53| Pp_box (* Horizontal or Indent block: breaks lead to new line 54 only when necessary to print the content of the block, or 55 when it leads to a new indentation of the current line *) 56| Pp_fits (* Internal usage: when a block fits on a single line *) 57 58and tblock = Pp_tbox of int list ref (* Tabulation box *) 59;; 60 61(* The Queue: 62 contains all formatting elements. 63 elements are tuples (size, token, length), where 64 size is set when the size of the block is known 65 len is the declared length of the token. *) 66type pp_queue_elem = { 67 mutable elem_size : size; token : pp_token; length : int 68};; 69 70(* Scan stack: 71 each element is (left_total, queue element) where left_total 72 is the value of pp_left_total when the element has been enqueued. *) 73type pp_scan_elem = Scan_elem of int * pp_queue_elem;; 74 75(* Formatting stack: 76 used to break the lines while printing tokens. 77 The formatting stack contains the description of 78 the currently active blocks. *) 79type pp_format_elem = Format_elem of block_type * int;; 80 81(* General purpose queues, used in the formatter. *) 82type 'a queue_elem = | Nil | Cons of 'a queue_cell 83and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};; 84 85type 'a queue = { 86 mutable insert : 'a queue_elem; 87 mutable body : 'a queue_elem 88};; 89 90(* The formatter specific tag handling functions. *) 91type formatter_tag_functions = { 92 mark_open_tag : tag -> string; 93 mark_close_tag : tag -> string; 94 print_open_tag : tag -> unit; 95 print_close_tag : tag -> unit; 96 97};; 98 99(* A formatter with all its machinery. *) 100type formatter = { 101 mutable pp_scan_stack : pp_scan_elem list; 102 mutable pp_format_stack : pp_format_elem list; 103 mutable pp_tbox_stack : tblock list; 104 mutable pp_tag_stack : tag list; 105 mutable pp_mark_stack : tag list; 106 (* Global variables: default initialization is 107 set_margin 78 108 set_min_space_left 0. *) 109 (* Value of right margin. *) 110 mutable pp_margin : int; 111 (* Minimal space left before margin, when opening a block. *) 112 mutable pp_min_space_left : int; 113 (* Maximum value of indentation: 114 no blocks can be opened further. *) 115 mutable pp_max_indent : int; 116 (* Space remaining on the current line. *) 117 mutable pp_space_left : int; 118 (* Current value of indentation. *) 119 mutable pp_current_indent : int; 120 (* True when the line has been broken by the pretty-printer. *) 121 mutable pp_is_new_line : bool; 122 (* Total width of tokens already printed. *) 123 mutable pp_left_total : int; 124 (* Total width of tokens ever put in queue. *) 125 mutable pp_right_total : int; 126 (* Current number of opened blocks. *) 127 mutable pp_curr_depth : int; 128 (* Maximum number of blocks which can be simultaneously opened. *) 129 mutable pp_max_boxes : int; 130 (* Ellipsis string. *) 131 mutable pp_ellipsis : string; 132 (* Output function. *) 133 mutable pp_output_function : string -> int -> int -> unit; 134 (* Flushing function. *) 135 mutable pp_flush_function : unit -> unit; 136 (* Output of new lines. *) 137 mutable pp_output_newline : unit -> unit; 138 (* Output of indentation spaces. *) 139 mutable pp_output_spaces : int -> unit; 140 (* Are tags printed ? *) 141 mutable pp_print_tags : bool; 142 (* Are tags marked ? *) 143 mutable pp_mark_tags : bool; 144 (* Find opening and closing markers of tags. *) 145 mutable pp_mark_open_tag : tag -> string; 146 mutable pp_mark_close_tag : tag -> string; 147 mutable pp_print_open_tag : tag -> unit; 148 mutable pp_print_close_tag : tag -> unit; 149 (* The pretty-printer queue. *) 150 mutable pp_queue : pp_queue_elem queue 151};; 152 153(************************************************************** 154 155 Auxilliaries and basic functions. 156 157 **************************************************************) 158 159 160(* Queues auxilliaries. *) 161let make_queue () = {insert = Nil; body = Nil};; 162 163let clear_queue q = q.insert <- Nil; q.body <- Nil;; 164 165let add_queue x q = 166 let c = Cons {head = x; tail = Nil} in 167 match q with 168 | {insert = Cons cell} -> q.insert <- c; cell.tail <- c 169 (* Invariant: when insert is Nil body should be Nil. *) 170 | _ -> q.insert <- c; q.body <- c;; 171 172exception Empty_queue;; 173 174let peek_queue = function 175 | {body = Cons {head = x}} -> x 176 | _ -> raise Empty_queue;; 177 178let take_queue = function 179 | {body = Cons {head = x; tail = tl}} as q -> 180 q.body <- tl; 181 if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) 182 x 183 | _ -> raise Empty_queue;; 184 185(* Enter a token in the pretty-printer queue. *) 186let pp_enqueue state ({length = len} as token) = 187 state.pp_right_total <- state.pp_right_total + len; 188 add_queue token state.pp_queue;; 189 190let pp_clear_queue state = 191 state.pp_left_total <- 1; state.pp_right_total <- 1; 192 clear_queue state.pp_queue;; 193 194(* Pp_infinity: large value for default tokens size. 195 196 Pp_infinity is documented as being greater than 1e10; to avoid 197 confusion about the word ``greater'', we choose pp_infinity greater 198 than 1e10 + 1; for correct handling of tests in the algorithm, 199 pp_infinity must be even one more than 1e10 + 1; let's stand on the 200 safe side by choosing 1.e10+10. 201 202 Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is 203 the minimal upper bound for integers; now that max_int is defined, 204 this limit could also be defined as max_int - 1. 205 206 However, before setting pp_infinity to something around max_int, we 207 must carefully double-check all the integer arithmetic operations 208 that involve pp_infinity, since any overflow would wreck havoc the 209 pretty-printing algorithm's invariants. Given that this arithmetic 210 correctness check is difficult and error prone and given that 1e10 211 + 1 is in practice large enough, there is no need to attempt to set 212 pp_infinity to the theoretically maximum limit. Is it not worth the 213 burden ! *) 214 215let pp_infinity = 1000000010;; 216 217(* Output functions for the formatter. *) 218let pp_output_string state s = state.pp_output_function s 0 (String.length s) 219and pp_output_newline state = state.pp_output_newline ();; 220 221let pp_display_blanks state n = state.pp_output_spaces n;; 222 223(* To format a break, indenting a new line. *) 224let break_new_line state offset width = 225 pp_output_newline state; 226 state.pp_is_new_line <- true; 227 let indent = state.pp_margin - width + offset in 228 (* Don't indent more than pp_max_indent. *) 229 let real_indent = min state.pp_max_indent indent in 230 state.pp_current_indent <- real_indent; 231 state.pp_space_left <- state.pp_margin - state.pp_current_indent; 232 pp_display_blanks state state.pp_current_indent;; 233 234(* To force a line break inside a block: no offset is added. *) 235let break_line state width = break_new_line state 0 width;; 236 237(* To format a break that fits on the current line. *) 238let break_same_line state width = 239 state.pp_space_left <- state.pp_space_left - width; 240 pp_display_blanks state width;; 241 242(* To indent no more than pp_max_indent, if one tries to open a block 243 beyond pp_max_indent, then the block is rejected on the left 244 by simulating a break. *) 245let pp_force_break_line state = 246 match state.pp_format_stack with 247 | Format_elem (bl_ty, width) :: _ -> 248 if width > state.pp_space_left then 249 (match bl_ty with 250 | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) 251 | _ -> pp_output_newline state;; 252 253(* To skip a token, if the previous line has been broken. *) 254let pp_skip_token state = 255 (* When calling pp_skip_token the queue cannot be empty. *) 256 match take_queue state.pp_queue with 257 {elem_size = size; length = len} -> 258 state.pp_left_total <- state.pp_left_total - len; 259 state.pp_space_left <- state.pp_space_left + int_of_size size;; 260 261(************************************************************** 262 263 The main pretting printing functions. 264 265 **************************************************************) 266 267(* To format a token. *) 268let format_pp_token state size = function 269 270 | Pp_text s -> 271 state.pp_space_left <- state.pp_space_left - size; 272 pp_output_string state s; 273 state.pp_is_new_line <- false 274 275 | Pp_begin (off, ty) -> 276 let insertion_point = state.pp_margin - state.pp_space_left in 277 if insertion_point > state.pp_max_indent then 278 (* can't open a block right there. *) 279 begin pp_force_break_line state end; 280 let offset = state.pp_space_left - off in 281 let bl_type = 282 begin match ty with 283 | Pp_vbox -> Pp_vbox 284 | _ -> if size > state.pp_space_left then ty else Pp_fits 285 end in 286 state.pp_format_stack <- 287 Format_elem (bl_type, offset) :: state.pp_format_stack 288 289 | Pp_end -> 290 begin match state.pp_format_stack with 291 | x :: (y :: l as ls) -> state.pp_format_stack <- ls 292 | _ -> () (* No more block to close. *) 293 end 294 295 | Pp_tbegin (Pp_tbox _ as tbox) -> 296 state.pp_tbox_stack <- tbox :: state.pp_tbox_stack 297 298 | Pp_tend -> 299 begin match state.pp_tbox_stack with 300 | x :: ls -> state.pp_tbox_stack <- ls 301 | _ -> () (* No more tabulation block to close. *) 302 end 303 304 | Pp_stab -> 305 begin match state.pp_tbox_stack with 306 | Pp_tbox tabs :: _ -> 307 let rec add_tab n = function 308 | [] -> [n] 309 | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in 310 tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs 311 | _ -> () (* No opened tabulation block. *) 312 end 313 314 | Pp_tbreak (n, off) -> 315 let insertion_point = state.pp_margin - state.pp_space_left in 316 begin match state.pp_tbox_stack with 317 | Pp_tbox tabs :: _ -> 318 let rec find n = function 319 | x :: l -> if x >= n then x else find n l 320 | [] -> raise Not_found in 321 let tab = 322 match !tabs with 323 | x :: l -> 324 begin try find insertion_point !tabs with Not_found -> x end 325 | _ -> insertion_point in 326 let offset = tab - insertion_point in 327 if offset >= 0 then break_same_line state (offset + n) else 328 break_new_line state (tab + off) state.pp_margin 329 | _ -> () (* No opened tabulation block. *) 330 end 331 332 | Pp_newline -> 333 begin match state.pp_format_stack with 334 | Format_elem (_, width) :: _ -> break_line state width 335 | _ -> pp_output_newline state 336 end 337 338 | Pp_if_newline -> 339 if state.pp_current_indent != state.pp_margin - state.pp_space_left 340 then pp_skip_token state 341 342 | Pp_break (n, off) -> 343 begin match state.pp_format_stack with 344 | Format_elem (ty, width) :: _ -> 345 begin match ty with 346 | Pp_hovbox -> 347 if size > state.pp_space_left 348 then break_new_line state off width 349 else break_same_line state n 350 | Pp_box -> 351 (* Have the line just been broken here ? *) 352 if state.pp_is_new_line then break_same_line state n else 353 if size > state.pp_space_left 354 then break_new_line state off width else 355 (* break the line here leads to new indentation ? *) 356 if state.pp_current_indent > state.pp_margin - width + off 357 then break_new_line state off width 358 else break_same_line state n 359 | Pp_hvbox -> break_new_line state off width 360 | Pp_fits -> break_same_line state n 361 | Pp_vbox -> break_new_line state off width 362 | Pp_hbox -> break_same_line state n 363 end 364 | _ -> () (* No opened block. *) 365 end 366 367 | Pp_open_tag tag_name -> 368 let marker = state.pp_mark_open_tag tag_name in 369 pp_output_string state marker; 370 state.pp_mark_stack <- tag_name :: state.pp_mark_stack 371 372 | Pp_close_tag -> 373 begin match state.pp_mark_stack with 374 | tag_name :: tags -> 375 let marker = state.pp_mark_close_tag tag_name in 376 pp_output_string state marker; 377 state.pp_mark_stack <- tags 378 | _ -> () (* No more tag to close. *) 379 end;; 380 381(* Print if token size is known or printing is delayed. 382 Size is known when not negative. 383 Printing is delayed when the text waiting in the queue requires 384 more room to format than exists on the current line. *) 385let rec advance_left state = 386 try 387 match peek_queue state.pp_queue with 388 {elem_size = size; token = tok; length = len} -> 389 let size = int_of_size size in 390 if not 391 (size < 0 && 392 (state.pp_right_total - state.pp_left_total < state.pp_space_left)) 393 then begin 394 ignore(take_queue state.pp_queue); 395 format_pp_token state (if size < 0 then pp_infinity else size) tok; 396 state.pp_left_total <- len + state.pp_left_total; 397 advance_left state 398 end 399 with Empty_queue -> ();; 400 401let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; 402 403(* To enqueue a string : try to advance. *) 404let make_queue_elem size tok len = 405 {elem_size = size; token = tok; length = len};; 406 407let enqueue_string_as state size s = 408 let len = int_of_size size in 409 enqueue_advance state (make_queue_elem size (Pp_text s) len);; 410 411let enqueue_string state s = 412 let len = String.length s in 413 enqueue_string_as state (size_of_int len) s;; 414 415(* Routines for scan stack 416 determine sizes of blocks. *) 417 418(* The scan_stack is never empty. *) 419let scan_stack_bottom = 420 let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in 421 [Scan_elem (-1, q_elem)];; 422 423(* Set size of blocks on scan stack: 424 if ty = true then size of break is set else size of block is set; 425 in each case pp_scan_stack is popped. *) 426let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; 427 428(* Pattern matching on scan stack is exhaustive, 429 since scan_stack is never empty. 430 Pattern matching on token in scan stack is also exhaustive, 431 since scan_push is used on breaks and opening of boxes. *) 432let set_size state ty = 433 match state.pp_scan_stack with 434 | Scan_elem 435 (left_tot, 436 ({elem_size = size; token = tok} as queue_elem)) :: t -> 437 let size = int_of_size size in 438 (* test if scan stack contains any data that is not obsolete. *) 439 if left_tot < state.pp_left_total then clear_scan_stack state else 440 begin match tok with 441 | Pp_break (_, _) | Pp_tbreak (_, _) -> 442 if ty then 443 begin 444 queue_elem.elem_size <- size_of_int (state.pp_right_total + size); 445 state.pp_scan_stack <- t 446 end 447 | Pp_begin (_, _) -> 448 if not ty then 449 begin 450 queue_elem.elem_size <- size_of_int (state.pp_right_total + size); 451 state.pp_scan_stack <- t 452 end 453 | _ -> () (* scan_push is only used for breaks and boxes. *) 454 end 455 | _ -> () (* scan_stack is never empty. *);; 456 457(* Push a token on scan stack. If b is true set_size is called. *) 458let scan_push state b tok = 459 pp_enqueue state tok; 460 if b then set_size state true; 461 state.pp_scan_stack <- 462 Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; 463 464(* To open a new block : 465 the user may set the depth bound pp_max_boxes 466 any text nested deeper is printed as the ellipsis string. *) 467let pp_open_box_gen state indent br_ty = 468 state.pp_curr_depth <- state.pp_curr_depth + 1; 469 if state.pp_curr_depth < state.pp_max_boxes then 470 let elem = 471 make_queue_elem 472 (size_of_int (- state.pp_right_total)) 473 (Pp_begin (indent, br_ty)) 474 0 in 475 scan_push state false elem else 476 if state.pp_curr_depth = state.pp_max_boxes 477 then enqueue_string state state.pp_ellipsis;; 478 479(* The box which is always opened. *) 480let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; 481 482(* Close a block, setting sizes of its subblocks. *) 483let pp_close_box state () = 484 if state.pp_curr_depth > 1 then 485 begin 486 if state.pp_curr_depth < state.pp_max_boxes then 487 begin 488 pp_enqueue state 489 {elem_size = size_of_int 0; token = Pp_end; length = 0}; 490 set_size state true; set_size state false 491 end; 492 state.pp_curr_depth <- state.pp_curr_depth - 1; 493 end;; 494 495(* Open a tag, pushing it on the tag stack. *) 496let pp_open_tag state tag_name = 497 if state.pp_print_tags then begin 498 state.pp_tag_stack <- tag_name :: state.pp_tag_stack; 499 state.pp_print_open_tag tag_name end; 500 if state.pp_mark_tags then 501 pp_enqueue state 502 {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};; 503 504(* Close a tag, popping it from the tag stack. *) 505let pp_close_tag state () = 506 if state.pp_mark_tags then 507 pp_enqueue state 508 {elem_size = size_of_int 0; token = Pp_close_tag; length = 0}; 509 if state.pp_print_tags then 510 begin match state.pp_tag_stack with 511 | tag_name :: tags -> 512 state.pp_print_close_tag tag_name; 513 state.pp_tag_stack <- tags 514 | _ -> () (* No more tag to close. *) 515 end;; 516 517let pp_set_print_tags state b = state.pp_print_tags <- b;; 518let pp_set_mark_tags state b = state.pp_mark_tags <- b;; 519let pp_get_print_tags state () = state.pp_print_tags;; 520let pp_get_mark_tags state () = state.pp_mark_tags;; 521let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; 522 523let pp_get_formatter_tag_functions state () = { 524 mark_open_tag = state.pp_mark_open_tag; 525 mark_close_tag = state.pp_mark_close_tag; 526 print_open_tag = state.pp_print_open_tag; 527 print_close_tag = state.pp_print_close_tag; 528};; 529 530let pp_set_formatter_tag_functions state { 531 mark_open_tag = mot; 532 mark_close_tag = mct; 533 print_open_tag = pot; 534 print_close_tag = pct; 535 } = 536 state.pp_mark_open_tag <- mot; 537 state.pp_mark_close_tag <- mct; 538 state.pp_print_open_tag <- pot; 539 state.pp_print_close_tag <- pct;; 540 541(* Initialize pretty-printer. *) 542let pp_rinit state = 543 pp_clear_queue state; 544 clear_scan_stack state; 545 state.pp_format_stack <- []; 546 state.pp_tbox_stack <- []; 547 state.pp_tag_stack <- []; 548 state.pp_mark_stack <- []; 549 state.pp_current_indent <- 0; 550 state.pp_curr_depth <- 0; 551 state.pp_space_left <- state.pp_margin; 552 pp_open_sys_box state;; 553 554(* Flushing pretty-printer queue. *) 555let pp_flush_queue state b = 556 while state.pp_curr_depth > 1 do 557 pp_close_box state () 558 done; 559 state.pp_right_total <- pp_infinity; 560 advance_left state; 561 if b then pp_output_newline state; 562 pp_rinit state;; 563 564(************************************************************** 565 566 Procedures to format objects, and use boxes 567 568 **************************************************************) 569 570(* To format a string. *) 571let pp_print_as_size state size s = 572 if state.pp_curr_depth < state.pp_max_boxes 573 then enqueue_string_as state size s;; 574 575let pp_print_as state isize s = 576 pp_print_as_size state (size_of_int isize) s;; 577 578let pp_print_string state s = 579 pp_print_as state (String.length s) s;; 580 581(* To format an integer. *) 582let pp_print_int state i = pp_print_string state (string_of_int i);; 583 584(* To format a float. *) 585let pp_print_float state f = pp_print_string state (string_of_float f);; 586 587(* To format a boolean. *) 588let pp_print_bool state b = pp_print_string state (string_of_bool b);; 589 590(* To format a char. *) 591let pp_print_char state c = 592 let s = String.create 1 in 593 s.[0] <- c; 594 pp_print_as state 1 s;; 595 596(* Opening boxes. *) 597let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox 598and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox 599 600and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox 601and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox 602and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; 603 604(* Print a new line after printing all queued text 605 (same for print_flush but without a newline). *) 606let pp_print_newline state () = 607 pp_flush_queue state true; state.pp_flush_function () 608and pp_print_flush state () = 609 pp_flush_queue state false; state.pp_flush_function ();; 610 611(* To get a newline when one does not want to close the current block. *) 612let pp_force_newline state () = 613 if state.pp_curr_depth < state.pp_max_boxes then 614 enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0);; 615 616(* To format something if the line has just been broken. *) 617let pp_print_if_newline state () = 618 if state.pp_curr_depth < state.pp_max_boxes then 619 enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0);; 620 621(* Breaks: indicate where a block may be broken. 622 If line is broken then offset is added to the indentation of the current 623 block else (the value of) width blanks are printed. 624 To do (?) : add a maximum width and offset value. *) 625let pp_print_break state width offset = 626 if state.pp_curr_depth < state.pp_max_boxes then 627 let elem = 628 make_queue_elem 629 (size_of_int (- state.pp_right_total)) 630 (Pp_break (width, offset)) 631 width in 632 scan_push state true elem;; 633 634let pp_print_space state () = pp_print_break state 1 0 635and pp_print_cut state () = pp_print_break state 0 0;; 636 637(* Tabulation boxes. *) 638let pp_open_tbox state () = 639 state.pp_curr_depth <- state.pp_curr_depth + 1; 640 if state.pp_curr_depth < state.pp_max_boxes then 641 let elem = 642 make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in 643 enqueue_advance state elem;; 644 645(* Close a tabulation block. *) 646let pp_close_tbox state () = 647 if state.pp_curr_depth > 1 then begin 648 if state.pp_curr_depth < state.pp_max_boxes then 649 let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in 650 enqueue_advance state elem; 651 state.pp_curr_depth <- state.pp_curr_depth - 1 end;; 652 653(* Print a tabulation break. *) 654let pp_print_tbreak state width offset = 655 if state.pp_curr_depth < state.pp_max_boxes then 656 let elem = 657 make_queue_elem 658 (size_of_int (- state.pp_right_total)) 659 (Pp_tbreak (width, offset)) 660 width in 661 scan_push state true elem;; 662 663let pp_print_tab state () = pp_print_tbreak state 0 0;; 664 665let pp_set_tab state () = 666 if state.pp_curr_depth < state.pp_max_boxes then 667 let elem = 668 make_queue_elem (size_of_int 0) Pp_stab 0 in 669 enqueue_advance state elem;; 670 671(************************************************************** 672 673 Procedures to control the pretty-printers 674 675 **************************************************************) 676 677(* Fit max_boxes. *) 678let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;; 679 680(* To know the current maximum number of boxes allowed. *) 681let pp_get_max_boxes state () = state.pp_max_boxes;; 682 683let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; 684 685(* Ellipsis. *) 686let pp_set_ellipsis_text state s = state.pp_ellipsis <- s 687and pp_get_ellipsis_text state () = state.pp_ellipsis;; 688 689(* To set the margin of pretty-printer. *) 690let pp_limit n = 691 if n < pp_infinity then n else pred pp_infinity;; 692 693let pp_set_min_space_left state n = 694 if n >= 1 then 695 let n = pp_limit n in 696 state.pp_min_space_left <- n; 697 state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; 698 pp_rinit state;; 699 700(* Initially, we have : 701 pp_max_indent = pp_margin - pp_min_space_left, and 702 pp_space_left = pp_margin. *) 703let pp_set_max_indent state n = 704 pp_set_min_space_left state (state.pp_margin - n);; 705let pp_get_max_indent state () = state.pp_max_indent;; 706 707let pp_set_margin state n = 708 if n >= 1 then 709 let n = pp_limit n in 710 state.pp_margin <- n; 711 let new_max_indent = 712 (* Try to maintain max_indent to its actual value. *) 713 if state.pp_max_indent <= state.pp_margin 714 then state.pp_max_indent else 715 (* If possible maintain pp_min_space_left to its actual value, 716 if this leads to a too small max_indent, take half of the 717 new margin, if it is greater than 1. *) 718 max (max (state.pp_margin - state.pp_min_space_left) 719 (state.pp_margin / 2)) 1 in 720 (* Rebuild invariants. *) 721 pp_set_max_indent state new_max_indent;; 722 723let pp_get_margin state () = state.pp_margin;; 724 725let pp_set_formatter_output_functions state f g = 726 state.pp_output_function <- f; state.pp_flush_function <- g;; 727let pp_get_formatter_output_functions state () = 728 (state.pp_output_function, state.pp_flush_function);; 729 730let pp_set_all_formatter_output_functions state 731 ~out:f ~flush:g ~newline:h ~spaces:i = 732 pp_set_formatter_output_functions state f g; 733 state.pp_output_newline <- (function () -> h ()); 734 state.pp_output_spaces <- (function n -> i n);; 735let pp_get_all_formatter_output_functions state () = 736 (state.pp_output_function, state.pp_flush_function, 737 state.pp_output_newline, state.pp_output_spaces);; 738 739let pp_set_formatter_out_channel state os = 740 state.pp_output_function <- output os; 741 state.pp_flush_function <- (fun () -> flush os);; 742 743(************************************************************** 744 745 Creation of specific formatters 746 747 **************************************************************) 748 749let default_pp_mark_open_tag s = "<" ^ s ^ ">";; 750let default_pp_mark_close_tag s = "</" ^ s ^ ">";; 751 752let default_pp_print_open_tag s = ();; 753let default_pp_print_close_tag = default_pp_print_open_tag;; 754 755let pp_make_formatter f g h i = 756 (* The initial state of the formatter contains a dummy box. *) 757 let pp_q = make_queue () in 758 let sys_tok = 759 make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in 760 add_queue sys_tok pp_q; 761 let sys_scan_stack = 762 (Scan_elem (1, sys_tok)) :: scan_stack_bottom in 763 {pp_scan_stack = sys_scan_stack; 764 pp_format_stack = []; 765 pp_tbox_stack = []; 766 pp_tag_stack = []; 767 pp_mark_stack = []; 768 pp_margin = 78; 769 pp_min_space_left = 10; 770 pp_max_indent = 78 - 10; 771 pp_space_left = 78; 772 pp_current_indent = 0; 773 pp_is_new_line = true; 774 pp_left_total = 1; 775 pp_right_total = 1; 776 pp_curr_depth = 1; 777 pp_max_boxes = max_int; 778 pp_ellipsis = "."; 779 pp_output_function = f; 780 pp_flush_function = g; 781 pp_output_newline = h; 782 pp_output_spaces = i; 783 pp_print_tags = false; 784 pp_mark_tags = false; 785 pp_mark_open_tag = default_pp_mark_open_tag; 786 pp_mark_close_tag = default_pp_mark_close_tag; 787 pp_print_open_tag = default_pp_print_open_tag; 788 pp_print_close_tag = default_pp_print_close_tag; 789 pp_queue = pp_q 790 };; 791 792(* Default function to output spaces. *) 793let blank_line = String.make 80 ' ';; 794let rec display_blanks state n = 795 if n > 0 then 796 if n <= 80 then state.pp_output_function blank_line 0 n else 797 begin 798 state.pp_output_function blank_line 0 80; 799 display_blanks state (n - 80) 800 end;; 801 802(* Default function to output new lines. *) 803let display_newline state () = state.pp_output_function "\n" 0 1;; 804 805let make_formatter f g = 806 let ff = pp_make_formatter f g ignore ignore in 807 ff.pp_output_newline <- display_newline ff; 808 ff.pp_output_spaces <- display_blanks ff; 809 ff;; 810 811let formatter_of_out_channel oc = 812 make_formatter (output oc) (fun () -> flush oc);; 813 814let formatter_of_buffer b = 815 make_formatter (Buffer.add_substring b) ignore;; 816 817let stdbuf = Buffer.create 512;; 818 819let str_formatter = formatter_of_buffer stdbuf;; 820let std_formatter = formatter_of_out_channel stdout;; 821let err_formatter = formatter_of_out_channel stderr;; 822 823let flush_str_formatter () = 824 pp_flush_queue str_formatter false; 825 let s = Buffer.contents stdbuf in 826 Buffer.reset stdbuf; 827 s;; 828 829(************************************************************** 830 831 Basic functions on the standard formatter 832 833 **************************************************************) 834 835let open_hbox = pp_open_hbox std_formatter 836and open_vbox = pp_open_vbox std_formatter 837and open_hvbox = pp_open_hvbox std_formatter 838and open_hovbox = pp_open_hovbox std_formatter 839and open_box = pp_open_box std_formatter 840and close_box = pp_close_box std_formatter 841and open_tag = pp_open_tag std_formatter 842and close_tag = pp_close_tag std_formatter 843and print_as = pp_print_as std_formatter 844and print_string = pp_print_string std_formatter 845and print_int = pp_print_int std_formatter 846and print_float = pp_print_float std_formatter 847and print_char = pp_print_char std_formatter 848and print_bool = pp_print_bool std_formatter 849and print_break = pp_print_break std_formatter 850and print_cut = pp_print_cut std_formatter 851and print_space = pp_print_space std_formatter 852and force_newline = pp_force_newline std_formatter 853and print_flush = pp_print_flush std_formatter 854and print_newline = pp_print_newline std_formatter 855and print_if_newline = pp_print_if_newline std_formatter 856 857and open_tbox = pp_open_tbox std_formatter 858and close_tbox = pp_close_tbox std_formatter 859and print_tbreak = pp_print_tbreak std_formatter 860 861and set_tab = pp_set_tab std_formatter 862and print_tab = pp_print_tab std_formatter 863 864and set_margin = pp_set_margin std_formatter 865and get_margin = pp_get_margin std_formatter 866 867and set_max_indent = pp_set_max_indent std_formatter 868and get_max_indent = pp_get_max_indent std_formatter 869 870and set_max_boxes = pp_set_max_boxes std_formatter 871and get_max_boxes = pp_get_max_boxes std_formatter 872and over_max_boxes = pp_over_max_boxes std_formatter 873 874and set_ellipsis_text = pp_set_ellipsis_text std_formatter 875and get_ellipsis_text = pp_get_ellipsis_text std_formatter 876 877and set_formatter_out_channel = 878 pp_set_formatter_out_channel std_formatter 879 880and set_formatter_output_functions = 881 pp_set_formatter_output_functions std_formatter 882and get_formatter_output_functions = 883 pp_get_formatter_output_functions std_formatter 884 885and set_all_formatter_output_functions = 886 pp_set_all_formatter_output_functions std_formatter 887and get_all_formatter_output_functions = 888 pp_get_all_formatter_output_functions std_formatter 889 890and set_formatter_tag_functions = 891 pp_set_formatter_tag_functions std_formatter 892and get_formatter_tag_functions = 893 pp_get_formatter_tag_functions std_formatter 894and set_print_tags = 895 pp_set_print_tags std_formatter 896and get_print_tags = 897 pp_get_print_tags std_formatter 898and set_mark_tags = 899 pp_set_mark_tags std_formatter 900and get_mark_tags = 901 pp_get_mark_tags std_formatter 902and set_tags = 903 pp_set_tags std_formatter 904;; 905 906 907(************************************************************** 908 909 Printf implementation. 910 911 **************************************************************) 912 913(* Error messages when processing formats. *) 914 915(* Trailer: giving up at character number ... *) 916let giving_up mess fmt i = 917 "fprintf: " ^ mess ^ " ``" ^ fmt ^ "'', \ 918 giving up at character number " ^ string_of_int i ^ 919 (if i < String.length fmt 920 then " (" ^ String.make 1 fmt.[i] ^ ")." 921 else String.make 1 '.');; 922 923(* When an invalid format deserves a special error explanation. *) 924let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; 925 926(* Standard invalid format. *) 927let invalid_format fmt i = format_invalid_arg "bad format" fmt i;; 928 929(* Cannot find a valid integer into that format. *) 930let invalid_integer fmt i = 931 invalid_arg (giving_up "bad integer specification" fmt i);; 932 933(* Finding an integer out of a sub-string of the format. *) 934let format_int_of_string fmt i s = 935 let sz = 936 try int_of_string s with 937 | Failure s -> invalid_integer fmt i in 938 size_of_int sz;; 939 940(* Getting strings out of buffers. *) 941let get_buffer_out b = 942 let s = Buffer.contents b in 943 Buffer.reset b; 944 s;; 945 946(* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]: 947 to extract contents of [ppf] as a string we flush [ppf] and get the string 948 out of [b]. *) 949let string_out b ppf = 950 pp_flush_queue ppf false; 951 get_buffer_out b;; 952 953(* Applies [printer] to a formatter that outputs on a fresh buffer, 954 then returns the resulting material. *) 955let exstring printer arg = 956 let b = Buffer.create 512 in 957 let ppf = formatter_of_buffer b in 958 printer ppf arg; 959 string_out b ppf;; 960 961(* To turn out a character accumulator into the proper string result. *) 962let implode_rev s0 = function 963 | [] -> s0 964 | l -> String.concat "" (List.rev (s0 :: l));; 965 966external format_to_string : ('a, 'b, 'c, 'd) format4 -> string = "%identity";; 967 968(* [fprintf_out] is the printf-like function generator: given the 969 - [str] flag that tells if we are printing into a string, 970 - the [out] function that has to be called at the end of formatting, 971 it generates a [fprintf] function that takes as arguments a [ppf] 972 formatter and a printing format to print the rest of arguments 973 according to the format. 974 Regular [fprintf]-like functions of this module are obtained via partial 975 applications of [fprintf_out]. *) 976let mkprintf str get_out = 977 let rec kprintf k fmt = 978 let fmt = format_to_string fmt in 979 let len = String.length fmt in 980 981 let kpr fmt v = 982 let ppf = get_out fmt in 983 let print_as = ref None in 984 let pp_print_as_char c = 985 match !print_as with 986 | None -> pp_print_char ppf c 987 | Some size -> 988 pp_print_as_size ppf size (String.make 1 c); 989 print_as := None 990 and pp_print_as_string s = 991 match !print_as with 992 | None -> pp_print_string ppf s 993 | Some size -> 994 pp_print_as_size ppf size s; 995 print_as := None in 996 997 let rec doprn n i = 998 if i >= len then Obj.magic (k ppf) else 999 match fmt.[i] with 1000 | '%' -> 1001 Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m 1002 | '@' -> 1003 let i = succ i in 1004 if i >= len then invalid_format fmt i else 1005 begin match fmt.[i] with 1006 | '[' -> 1007 do_pp_open_box ppf n (succ i) 1008 | ']' -> 1009 pp_close_box ppf (); 1010 doprn n (succ i) 1011 | '{' -> 1012 do_pp_open_tag ppf n (succ i) 1013 | '}' -> 1014 pp_close_tag ppf (); 1015 doprn n (succ i) 1016 | ' ' -> 1017 pp_print_space ppf (); 1018 doprn n (succ i) 1019 | ',' -> 1020 pp_print_cut ppf (); 1021 doprn n (succ i) 1022 | '?' -> 1023 pp_print_flush ppf (); 1024 doprn n (succ i) 1025 | '.' -> 1026 pp_print_newline ppf (); 1027 doprn n (succ i) 1028 | '\n' -> 1029 pp_force_newline ppf (); 1030 doprn n (succ i) 1031 | ';' -> 1032 do_pp_break ppf n (succ i) 1033 | '<' -> 1034 let got_size size n i = 1035 print_as := Some size; 1036 doprn n (skip_gt i) in 1037 get_int n (succ i) got_size 1038 | '@' as c -> 1039 pp_print_as_char c; 1040 doprn n (succ i) 1041 | c -> invalid_format fmt i 1042 end 1043 | c -> 1044 pp_print_as_char c; 1045 doprn n (succ i) 1046 1047 and cont_s n s i = 1048 pp_print_as_string s; doprn n i 1049 and cont_a n printer arg i = 1050 if str then 1051 pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) 1052 else 1053 printer ppf arg; 1054 doprn n i 1055 and cont_t n printer i = 1056 if str then 1057 pp_print_as_string ((Obj.magic printer : unit -> string) ()) 1058 else 1059 printer ppf; 1060 doprn n i 1061 and cont_f n i = 1062 pp_print_flush ppf (); doprn n i 1063 1064 and cont_m n sfmt i = 1065 kprintf (Obj.magic (fun _ -> doprn n i)) sfmt 1066 1067 and get_int n i c = 1068 if i >= len then invalid_integer fmt i else 1069 match fmt.[i] with 1070 | ' ' -> get_int n (succ i) c 1071 | '%' -> 1072 let cont_s n s i = c (format_int_of_string fmt i s) n i 1073 and cont_a n printer arg i = invalid_integer fmt i 1074 and cont_t n printer i = invalid_integer fmt i 1075 and cont_f n i = invalid_integer fmt i 1076 and cont_m n sfmt i = invalid_integer fmt i in 1077 Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m 1078 | _ -> 1079 let rec get j = 1080 if j >= len then invalid_integer fmt j else 1081 match fmt.[j] with 1082 | '0' .. '9' | '-' -> get (succ j) 1083 | _ -> 1084 let size = 1085 if j = i then size_of_int 0 else 1086 format_int_of_string fmt j (String.sub fmt i (j - i)) in 1087 c size n j in 1088 get i 1089 1090 and skip_gt i = 1091 if i >= len then invalid_format fmt i else 1092 match fmt.[i] with 1093 | ' ' -> skip_gt (succ i) 1094 | '>' -> succ i 1095 | _ -> invalid_format fmt i 1096 1097 and get_box_kind i = 1098 if i >= len then Pp_box, i else 1099 match fmt.[i] with 1100 | 'h' -> 1101 let i = succ i in 1102 if i >= len then Pp_hbox, i else 1103 begin match fmt.[i] with 1104 | 'o' -> 1105 let i = succ i in 1106 if i >= len then format_invalid_arg "bad box format" fmt i else 1107 begin match fmt.[i] with 1108 | 'v' -> Pp_hovbox, succ i 1109 | c -> 1110 format_invalid_arg 1111 ("bad box name ho" ^ String.make 1 c) fmt i end 1112 | 'v' -> Pp_hvbox, succ i 1113 | c -> Pp_hbox, i 1114 end 1115 | 'b' -> Pp_box, succ i 1116 | 'v' -> Pp_vbox, succ i 1117 | _ -> Pp_box, i 1118 1119 and get_tag_name n i c = 1120 let rec get accu n i j = 1121 if j >= len 1122 then c (implode_rev (String.sub fmt i (j - i)) accu) n j else 1123 match fmt.[j] with 1124 | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) n j 1125 | '%' -> 1126 let s0 = String.sub fmt i (j - i) in 1127 let cont_s n s i = get (s :: s0 :: accu) n i i 1128 and cont_a n printer arg i = 1129 let s = 1130 if str 1131 then (Obj.magic printer : unit -> _ -> string) () arg 1132 else exstring printer arg in 1133 get (s :: s0 :: accu) n i i 1134 and cont_t n printer i = 1135 let s = 1136 if str 1137 then (Obj.magic printer : unit -> string) () 1138 else exstring (fun ppf () -> printer ppf) () in 1139 get (s :: s0 :: accu) n i i 1140 and cont_f n i = 1141 format_invalid_arg "bad tag name specification" fmt i 1142 and cont_m n sfmt i = 1143 format_invalid_arg "bad tag name specification" fmt i in 1144 Printf.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m 1145 | c -> get accu n i (succ j) in 1146 get [] n i i 1147 1148 and do_pp_break ppf n i = 1149 if i >= len then begin pp_print_space ppf (); doprn n i end else 1150 match fmt.[i] with 1151 | '<' -> 1152 let rec got_nspaces nspaces n i = 1153 get_int n i (got_offset nspaces) 1154 and got_offset nspaces offset n i = 1155 pp_print_break ppf (int_of_size nspaces) (int_of_size offset); 1156 doprn n (skip_gt i) in 1157 get_int n (succ i) got_nspaces 1158 | c -> pp_print_space ppf (); doprn n i 1159 1160 and do_pp_open_box ppf n i = 1161 if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else 1162 match fmt.[i] with 1163 | '<' -> 1164 let kind, i = get_box_kind (succ i) in 1165 let got_size size n i = 1166 pp_open_box_gen ppf (int_of_size size) kind; 1167 doprn n (skip_gt i) in 1168 get_int n i got_size 1169 | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i 1170 1171 and do_pp_open_tag ppf n i = 1172 if i >= len then begin pp_open_tag ppf ""; doprn n i end else 1173 match fmt.[i] with 1174 | '<' -> 1175 let got_name tag_name n i = 1176 pp_open_tag ppf tag_name; 1177 doprn n (skip_gt i) in 1178 get_tag_name n (succ i) got_name 1179 | c -> pp_open_tag ppf ""; doprn n i in 1180 1181 doprn (Printf.index_of_int 0) 0 in 1182 1183 Printf.kapr kpr fmt in 1184 1185 kprintf;; 1186 1187(************************************************************** 1188 1189 Defining [fprintf] and various flavors of [fprintf]. 1190 1191 **************************************************************) 1192 1193let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; 1194 1195let fprintf ppf = kfprintf ignore ppf;; 1196let printf fmt = fprintf std_formatter fmt;; 1197let eprintf fmt = fprintf err_formatter fmt;; 1198 1199let kbprintf k b = 1200 mkprintf false (fun _ -> formatter_of_buffer b) k;; 1201 1202let bprintf b = kbprintf ignore b;; 1203 1204let ksprintf k = 1205 let b = Buffer.create 512 in 1206 let k ppf = k (string_out b ppf) in 1207 mkprintf true (fun _ -> formatter_of_buffer b) k;; 1208 1209let kprintf = ksprintf;; 1210 1211let sprintf fmt = ksprintf (fun s -> s) fmt;; 1212 1213at_exit print_flush;; 1214