libmojave/stdlib/lm_format.ml

   1 (*
   2  * Convert to standard format.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * Copyright (C) 2000-2005 Mojave Group, Caltech
   7  *
   8  * This library is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU Lesser General Public
  10  * License as published by the Free Software Foundation,
  11  * version 2.1 of the License.
  12  *
  13  * This library is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16  * Lesser General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with this library; if not, write to the Free Software
  20  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  21  *
  22  * Additional permission is given to link this library with the
  23  * OpenSSL project's "OpenSSL" library, and with the OCaml runtime,
  24  * and you may distribute the linked executables.  See the file
  25  * LICENSE.libmojave for more details.
  26  *
  27  * Author: Jason Hickey
  28  * jyh@cs.caltech.edu
  29  *)
  30 open Lm_rformat
  31 open Lm_rformat_raw
  32 open Lm_rformat_text
  33 open Lm_make_printf
  34
  35 (************************************************************************
  36  * TYPES                                                                *
  37  ************************************************************************)
  38
  39 (*
  40  * Multiple formatted output.
  41  *)
  42 type formatter =
  43    { mutable form_buffer      : buffer;
  44      mutable form_out_string  : (string -> int -> int -> unit);
  45      mutable form_out_flush   : (unit -> unit);
  46      mutable form_out_newline : (unit -> unit);
  47      mutable form_out_space   : (int -> unit);
  48      mutable form_max_boxes   : int;
  49      mutable form_max_indent  : int;
  50      mutable form_ellipsis    : string;
  51      mutable form_margin      : int;
  52      mutable form_divert      : (buffer -> unit) option
  53    }
  54
  55 (************************************************************************
  56  * STANDARD OPERATIONS                                                  *
  57  ************************************************************************)
  58
  59 let default_max_boxes = max_int
  60 let default_max_indent = max_int
  61 let default_ellipsis = "..."
  62 let default_margin = 80
  63
  64 let output_substring = output
  65
  66 (*
  67  * Flush the buffer.
  68  *)
  69 let flush_form form =
  70    let { form_buffer      = buf;
  71          form_out_flush   = flush;
  72          form_out_string  = out_string;
  73          form_out_newline = out_newline;
  74          form_out_space   = out_space;
  75          form_margin      = margin;
  76          form_divert      = divert
  77        } = form
  78    in
  79       match divert with
  80          Some divert ->
  81             format_flush buf;
  82             divert buf;
  83             form.form_buffer <- new_buffer ()
  84        | None ->
  85             let raw_printer =
  86                { raw_print_string  = out_string;
  87                  raw_print_newline = out_newline;
  88                  raw_print_spaces  = out_space;
  89                  raw_print_flush   = flush
  90                }
  91             in
  92             let printer = make_text_printer raw_printer in
  93                format_flush buf;
  94                print_to_printer buf margin printer;
  95                flush ();
  96                form.form_buffer <- new_buffer ()
  97
  98 (*
  99  * Generic operations.
 100  *)
 101 let pp_open_hbox form () =
 102    format_lzone form.form_buffer
 103
 104 let pp_open_vbox form tab =
 105    format_hzone form.form_buffer;
 106    format_pushm form.form_buffer tab
 107
 108 let pp_open_hvbox form tab =
 109    format_hzone form.form_buffer;
 110    format_pushm form.form_buffer tab
 111
 112 let pp_open_hovbox form tab =
 113    format_hzone form.form_buffer;
 114    format_pushm form.form_buffer tab
 115
 116 let pp_open_box = pp_open_hovbox
 117
 118 let pp_close_box form () =
 119    format_flush_popm form.form_buffer;
 120    format_ezone form.form_buffer
 121
 122 let pp_print_string form s =
 123    format_string form.form_buffer s
 124
 125 let pp_print_as form i s =
 126    let len = String.length s in
 127       if i < len then
 128          begin
 129             format_string form.form_buffer (String.sub s 0 i);
 130             format_izone form.form_buffer;
 131             format_string form.form_buffer (String.sub s i (len - i));
 132             format_ezone form.form_buffer
 133          end
 134       else
 135          begin
 136             format_string form.form_buffer s;
 137             if i > len then
 138                format_string form.form_buffer (String.make (i - len) ' ')
 139          end
 140
 141 let pp_print_int form i =
 142    format_int form.form_buffer i
 143
 144 let pp_print_float form x =
 145    format_string form.form_buffer (string_of_float x)
 146
 147 let pp_print_char form c =
 148    format_char form.form_buffer c
 149
 150 let pp_print_bool form x =
 151    format_string form.form_buffer (if x then "true" else "false")
 152
 153 let pp_print_break form nspaces offset =
 154    format_sbreak form.form_buffer (String.make nspaces ' ') (String.make offset ' ')
 155
 156 let pp_print_cut form () =
 157    format_sbreak form.form_buffer "" ""
 158
 159 let pp_print_space form () =
 160    format_hspace form.form_buffer
 161
 162 let pp_print_rbuffer form buffer =
 163    format_buffer form.form_buffer buffer;
 164    flush_form form
 165
 166 let pp_force_newline form () =
 167    format_newline form.form_buffer
 168
 169 let pp_print_flush form () =
 170    flush_form form
 171
 172 let pp_print_newline form () =
 173    format_newline form.form_buffer;
 174    flush_form form
 175
 176 let pp_print_if_newline _form () =
 177    ()
 178
 179 let pp_open_tbox _form () =
 180    ()
 181
 182 let pp_close_tbox _form () =
 183    ()
 184
 185 let pp_print_tbreak = pp_print_break
 186
 187 let pp_set_tab _form () =
 188    ()
 189
 190 let pp_print_tab _form () =
 191    ()
 192
 193 let pp_set_margin form margin =
 194    form.form_margin <- margin
 195
 196 let pp_get_margin form () =
 197    form.form_margin
 198
 199 let pp_set_max_indent form indent =
 200    form.form_max_indent <- indent
 201
 202 let pp_get_max_indent form () =
 203    form.form_max_indent
 204
 205 let pp_set_max_boxes form max =
 206    form.form_max_boxes <- max
 207
 208 let pp_get_max_boxes form () =
 209    form.form_max_boxes
 210
 211 let pp_over_max_boxes form () =
 212    format_depth form.form_buffer > form.form_max_boxes
 213
 214 let pp_set_ellipsis_text form text =
 215    form.form_ellipsis <- text
 216
 217 let pp_get_ellipsis_text form () =
 218    form.form_ellipsis
 219
 220 let pp_set_formatter_out_channel form outx =
 221    form.form_out_string <- output_substring outx;
 222    form.form_out_flush <- (fun () -> flush outx);
 223    form.form_out_newline <- (fun () -> output_char outx '\n');
 224    form.form_out_space <- (fun i ->
 225                                 for j = 0 to pred i do
 226                                    output_char outx ' '
 227                                 done)
 228
 229 let pp_set_formatter_output_functions form outx flush =
 230    form.form_out_string <- outx;
 231    form.form_out_flush <- flush
 232
 233 let pp_get_formatter_output_functions form () =
 234    form.form_out_string, form.form_out_flush
 235
 236 let pp_set_all_formatter_output_functions form outx flush outnewline outspace =
 237    form.form_out_string <- outx;
 238    form.form_out_flush <- flush;
 239    form.form_out_newline <- outnewline;
 240    form.form_out_space <- outspace
 241
 242 let pp_get_all_formatter_output_functions form () =
 243    form.form_out_string,
 244    form.form_out_flush,
 245    form.form_out_newline,
 246    form.form_out_space
 247
 248 (************************************************************************
 249  * STANDARD BUFFERS                                                     *
 250  ************************************************************************)
 251
 252 let formatter_of_out_channel outx =
 253    { form_buffer = new_buffer ();
 254      form_out_string = output_substring outx;
 255      form_out_flush = (fun () -> flush outx);
 256      form_out_newline = (fun () -> output_char outx '\n');
 257      form_out_space = (fun i ->
 258                             for j = 1 to i do
 259                                output_char outx ' '
 260                             done);
 261      form_max_boxes = default_max_boxes;
 262      form_max_indent = default_max_indent;
 263      form_ellipsis = default_ellipsis;
 264      form_margin = default_margin;
 265      form_divert = None
 266    }
 267
 268 let std_formatter = formatter_of_out_channel stdout
 269 let err_formatter = formatter_of_out_channel stderr
 270
 271 let formatter_of_buffer buf =
 272    { form_buffer = new_buffer ();
 273      form_out_string = Buffer.add_substring buf;
 274      form_out_flush = (fun () -> ());
 275      form_out_newline = (fun () -> Buffer.add_char buf '\n');
 276      form_out_space =
 277         (fun i ->
 278               for j = 1 to i do
 279                  Buffer.add_char buf ' '
 280               done);
 281      form_max_boxes = default_max_boxes;
 282      form_max_indent = default_max_indent;
 283      form_ellipsis = default_ellipsis;
 284      form_margin = default_margin;
 285      form_divert = None
 286    }
 287
 288 let stdbuf = Buffer.create 19
 289
 290 let str_formatter = formatter_of_buffer stdbuf
 291
 292 let flush_str_formatter () =
 293    flush_form str_formatter;
 294    let s = Buffer.contents stdbuf in
 295       Buffer.clear stdbuf;
 296       s
 297
 298 let make_formatter outx flush =
 299    { form_buffer = new_buffer ();
 300      form_out_string = outx;
 301      form_out_flush = flush;
 302      form_out_newline = (fun () -> outx "\n" 0 1);
 303      form_out_space = (fun i ->
 304                             for j = 1 to i do
 305                                outx " " 0 1
 306                             done);
 307      form_max_boxes = default_max_boxes;
 308      form_max_indent = default_max_indent;
 309      form_ellipsis = default_ellipsis;
 310      form_margin = default_margin;
 311      form_divert = None
 312    }
 313
 314 (*
 315  * Boxes.
 316  *)
 317 let open_box = pp_open_box std_formatter
 318 let open_vbox = pp_open_vbox std_formatter
 319 let open_hbox = pp_open_hbox std_formatter
 320 let open_hvbox = pp_open_hvbox std_formatter
 321 let open_hovbox = pp_open_hovbox std_formatter
 322 let close_box = pp_close_box std_formatter
 323
 324 (*
 325  * Formatting functions.
 326  *)
 327 let print_string = pp_print_string std_formatter
 328 let print_as = pp_print_as std_formatter
 329 let print_int = pp_print_int std_formatter
 330 let print_float = pp_print_float std_formatter
 331 let print_char = pp_print_char std_formatter
 332 let print_bool = pp_print_bool std_formatter
 333
 334 (*
 335  * Break hints.
 336  *)
 337 let print_space = pp_print_space std_formatter
 338 let print_cut = pp_print_cut std_formatter
 339 let print_break = pp_print_break std_formatter
 340 let print_flush = pp_print_flush std_formatter
 341 let print_newline = pp_print_newline std_formatter
 342 let force_newline = pp_force_newline std_formatter
 343 let print_if_newline = pp_print_if_newline std_formatter
 344
 345 (*
 346  * Margin.
 347  *)
 348 let set_margin = pp_set_margin std_formatter
 349 let get_margin = pp_get_margin std_formatter
 350
 351 (*
 352  * Indentation limit.
 353  *)
 354 let set_max_indent = pp_set_max_indent std_formatter
 355 let get_max_indent = pp_get_max_indent std_formatter
 356
 357 (*
 358  * Formatting depth.
 359  *)
 360 let set_max_boxes = pp_set_max_boxes std_formatter
 361 let get_max_boxes = pp_get_max_boxes std_formatter
 362 let over_max_boxes = pp_over_max_boxes std_formatter
 363
 364 (*
 365  * Tabulations.
 366  *)
 367 let open_tbox = pp_open_tbox std_formatter
 368 let close_tbox = pp_close_tbox std_formatter
 369 let print_tbreak = pp_print_tbreak std_formatter
 370 let set_tab = pp_set_tab std_formatter
 371 let print_tab = pp_print_tab std_formatter
 372
 373 (*
 374  * Ellipsis.
 375  *)
 376 let set_ellipsis_text = pp_set_ellipsis_text std_formatter
 377 let get_ellipsis_text = pp_get_ellipsis_text std_formatter
 378
 379 (*
 380  * Redirecting formatter output.
 381  *)
 382 let set_formatter_out_channel = pp_set_formatter_out_channel std_formatter
 383 let set_formatter_output_functions = pp_set_formatter_output_functions std_formatter
 384 let get_formatter_output_functions = pp_get_formatter_output_functions std_formatter
 385 let set_all_formatter_output_functions = pp_set_all_formatter_output_functions std_formatter
 386 let get_all_formatter_output_functions = pp_get_all_formatter_output_functions std_formatter
 387
 388 let divert formatter divert =
 389    formatter.form_divert <- divert
 390
 391 (************************************************************************
 392  * PRINTF
 393  ************************************************************************)
 394
 395 (*
 396  * Format args.
 397  *)
 398 module Args =
 399 struct
 400    type t = formatter
 401    type result = unit
 402
 403    let print_char = pp_print_char
 404    let print_string = pp_print_string
 405
 406    let open_box = pp_open_box
 407    let open_hbox fmt = pp_open_hbox fmt ()
 408    let open_vbox = pp_open_vbox
 409    let open_hvbox = pp_open_hvbox
 410    let open_hovbox = pp_open_hovbox
 411    let close_box fmt = pp_close_box fmt ()
 412
 413    let print_cut fmt = pp_print_cut fmt ()
 414    let print_space fmt = pp_print_space fmt ()
 415    let force_newline fmt = pp_force_newline fmt ()
 416    let print_break = pp_print_break
 417    let print_flush fmt = pp_print_flush fmt ()
 418    let print_newline fmt = pp_print_newline fmt ()
 419
 420    let exit _ = ()
 421 end
 422
 423 module StringArgs =
 424 struct
 425    type t = unit
 426    type result = string
 427
 428    let print_char () = pp_print_char str_formatter
 429    let print_string () = pp_print_string str_formatter
 430
 431    let open_box () = pp_open_box str_formatter
 432    let open_hbox () = pp_open_hbox str_formatter ()
 433    let open_vbox () = pp_open_vbox str_formatter
 434    let open_hvbox () = pp_open_hvbox str_formatter
 435    let open_hovbox () = pp_open_hovbox str_formatter
 436    let close_box () = pp_close_box str_formatter ()
 437
 438    let print_cut () = pp_print_cut str_formatter ()
 439    let print_space () = pp_print_space str_formatter ()
 440    let force_newline () = pp_force_newline str_formatter ()
 441    let print_break () = pp_print_break str_formatter
 442    let print_flush () = pp_print_flush str_formatter ()
 443    let print_newline () = pp_print_newline str_formatter ()
 444
 445    let exit = flush_str_formatter
 446 end
 447
 448 module FPrintf = MakePrintf (Args)
 449 module SPrintf = MakePrintf (StringArgs)
 450
 451 let fprintf = FPrintf.fprintf
 452
 453 let sprintf s =
 454    SPrintf.fprintf () s
 455
 456 let printf s =
 457    fprintf std_formatter s
 458
 459 let eprintf s =
 460    fprintf err_formatter s
 461
 462 let bprintf buf s =
 463    fprintf (formatter_of_buffer buf) s
 464
 465 (*
 466  * -*-
 467  * Local Variables:
 468  * Caml-master: "compile"
 469  * End:
 470  * -*-
 471  *)