(* $Id$ *) open Pp_control (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; \item[vbox:] Vertical block each break leads to a new line; \item[hvbox:] Horizontal-vertical block: same as vbox, except if this block is small enough to fit on a single line \item[hovbox:] Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block \item[tbox:] Tabulation block: go to tabulation marks and no line breaking (except if no mark yet on the reste of the line) \end{description} *) type block_type = | Pp_hbox of int | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int | Pp_tbox type 'a ppcmd_token = | Ppcmd_print of 'a | Ppcmd_box of block_type * ('a ppcmd_token Stream.t) | Ppcmd_print_break of int * int | Ppcmd_set_tab | Ppcmd_print_tbreak of int * int | Ppcmd_white_space of int | Ppcmd_force_newline | Ppcmd_print_if_broken | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_close_tbox type 'a ppdir_token = | Ppdir_ppcmds of 'a ppcmd_token Stream.t | Ppdir_print_newline | Ppdir_print_flush type std_ppcmds = (int*string) ppcmd_token Stream.t type 'a ppdirs = 'a ppdir_token Stream.t (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) Rem 2 : if used for an iso8859_1 encoded string, the result is wrong in very rare cases. Such a wrong case corresponds to any sequence of a character in range 192..253 immediately followed by a character in range 128..191 (typical case in french is "déçu" which is counted 3 instead of 4); then no real harm to use always utf8_length even if using an iso8859_1 encoding *) let utf8_length s = let len = String.length s and cnt = ref 0 and nc = ref 0 and p = ref 0 in while !p < len do begin match s.[!p] with | '\000'..'\127' -> nc := 0 (* ascii char *) | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *) | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) | '\254'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len && !nc > 0 do match s.[!p] with | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc | _ (* not a continuation byte *) -> nc := 0 done ; incr cnt done ; !cnt (* formatting commands *) let sTR s = Ppcmd_print (utf8_length s,s) let sTRas (i,s) = Ppcmd_print (i,s) let bRK (a,b) = Ppcmd_print_break (a,b) let tBRK (a,b) = Ppcmd_print_tbreak (a,b) let tAB = Ppcmd_set_tab let fNL = Ppcmd_force_newline let pifB = Ppcmd_print_if_broken let wS n = Ppcmd_white_space n (* derived commands *) let sPC = Ppcmd_print_break (1,0) let cUT = Ppcmd_print_break (0,0) let aLIGN = Ppcmd_print_break (0,0) let iNT n = sTR (string_of_int n) let rEAL r = sTR (string_of_float r) let bOOL b = sTR (string_of_bool b) let qSTRING s = sTR ("\""^(String.escaped s)^"\"") let qS = qSTRING (* boxing commands *) let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >] let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >] let hV n s = [< 'Ppcmd_box(Pp_hvbox n,s) >] let hOV n s = [< 'Ppcmd_box(Pp_hovbox n,s) >] let t s = [< 'Ppcmd_box(Pp_tbox,s) >] (* Opening and closing of boxes *) let hB n = Ppcmd_open_box(Pp_hbox n) let vB n = Ppcmd_open_box(Pp_vbox n) let hVB n = Ppcmd_open_box(Pp_hvbox n) let hOVB n = Ppcmd_open_box(Pp_hovbox n) let tB = Ppcmd_open_box Pp_tbox let cLOSE = Ppcmd_close_box let tCLOSE = Ppcmd_close_tbox (* pretty printing functions *) let pp_dirs ft = let maxbox = (get_gp ft).max_depth in let pp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n | Pp_tbox -> Format.pp_open_tbox ft () in let rec pp_cmd = function | Ppcmd_print(n,s) -> Format.pp_print_as ft n s | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) pp_open_box bty ; if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss; Format.pp_close_box ft () | Ppcmd_open_box bty -> pp_open_box bty | Ppcmd_close_box -> Format.pp_close_box ft () | Ppcmd_close_tbox -> Format.pp_close_tbox ft () | Ppcmd_white_space n -> Format.pp_print_break ft n 0 | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n | Ppcmd_set_tab -> Format.pp_set_tab ft () | Ppcmd_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n | Ppcmd_force_newline -> Format.pp_force_newline ft () | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () in let pp_dir = function | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream | Ppdir_print_newline -> Format.pp_print_newline ft () | Ppdir_print_flush -> Format.pp_print_flush ft () in fun dirstream -> try Stream.iter pp_dir dirstream with | e -> Format.pp_print_flush ft () ; raise e (* pretty print on stdout and stderr *) let pp_std_dirs = pp_dirs std_ft let pp_err_dirs = pp_dirs err_ft let pPCMDS x = Ppdir_ppcmds x (* pretty printing functions WITHOUT FLUSH *) let pP_with ft strm = pp_dirs ft [< 'pPCMDS strm >] let pPNL_with ft strm = pp_dirs ft [< 'pPCMDS [< strm ; 'Ppcmd_force_newline >] >] let warning_with ft string = pPNL_with ft [< 'sTR"Warning: " ; 'sTR string >] let wARN_with ft pps = pPNL_with ft [< 'sTR"Warning: " ; pps >] let pp_flush_with ft = Format.pp_print_flush ft (* pretty printing functions WITH FLUSH *) let mSG_with ft strm = pp_dirs ft [< 'pPCMDS strm ; 'Ppdir_print_flush >] let mSGNL_with ft strm = pp_dirs ft [< 'pPCMDS strm ; 'Ppdir_print_newline >] let wARNING_with ft strm= pp_dirs ft [<'pPCMDS ([<'sTR "Warning: "; strm>]); 'Ppdir_print_newline>] (* pretty printing functions WITHOUT FLUSH *) let pP = pP_with std_ft let pPNL = pPNL_with std_ft let pPERR = pP_with err_ft let pPERRNL = pPNL_with err_ft let message s = pPNL [< 'sTR s >] let warning = warning_with std_ft let wARN = wARN_with std_ft let pp_flush = Format.pp_print_flush std_ft let flush_all() = flush stderr; flush stdout; pp_flush() (* pretty printing functions WITH FLUSH *) let mSG = mSG_with std_ft let mSGNL = mSGNL_with std_ft let mSGERR = mSG_with err_ft let mSGERRNL = mSGNL_with err_ft let wARNING = wARNING_with std_ft