Fake printer

fakeformat.ml

[@@@ocaml.warning "-40"]

module CB = CamlinternalFormatBasics
module C = CamlinternalFormat
module F = Format

type ufmt = Format.formatter -> unit


(* copied from format.ml, don't ask *)
let compute_tag tag_acc =
  let buf = Buffer.create 16 in
  C.strput_acc buf tag_acc;
  let len = Buffer.length buf in
  if len < 2 then Buffer.contents buf
  else Buffer.sub buf 1 (len - 2)

(* Interpret a formatting entity on a formatter. *)
let fake_lit
  : CB.formatting_lit -> ufmt
  = function
    | CB.Close_box                 -> fun ppf -> F.pp_close_box ppf ()
    | CB.Close_tag                 -> fun ppf -> F.pp_close_tag ppf ()
    | CB.Break (_, width, offset)  -> fun ppf -> F.pp_print_break ppf width offset
    | CB.FFlush                    -> fun ppf -> F.pp_print_flush ppf ()
    | CB.Force_newline             -> fun ppf -> F.pp_force_newline ppf ()
    | CB.Flush_newline             -> fun ppf -> F.pp_print_newline ppf ()
    | CB.Magic_size (_, _)         -> ignore
    | CB.Escaped_at                -> fun ppf -> F.pp_print_char ppf '@'
    | CB.Escaped_percent           -> fun ppf -> F.pp_print_char ppf '%'
    | CB.Scan_indic c              -> fun ppf -> F.pp_print_char ppf '@'; F.pp_print_char ppf c

let fake_block ppx i = function
  | CB.Pp_hbox -> F.pp_open_hbox ppx ()
  | CB.Pp_vbox -> F.pp_open_vbox ppx i
  | CB.Pp_hvbox -> F.pp_open_hvbox ppx i
  | CB.Pp_hovbox -> F.pp_open_hovbox ppx i
  | CB.Pp_box -> F.pp_open_box ppx i
  | CB.Pp_fits -> ()

let rec fake_acc
  : unit -> (unit, string) CamlinternalFormat.acc -> ufmt
  = fun () -> function
    | C.Acc_string_literal (C.Acc_formatting_lit (acc, CB.Magic_size (_, size)), s)
    | C.Acc_data_string (C.Acc_formatting_lit (acc, CB.Magic_size (_, size)), s) ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_print_as ppf size s;
    | C.Acc_char_literal (C.Acc_formatting_lit (acc, CB.Magic_size (_, size)),c)
    | C.Acc_data_char (C.Acc_formatting_lit (acc, CB.Magic_size (_, size)),c) ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_print_as ppf size (String.make 1 c);

    | C.Acc_formatting_lit (acc, lit) ->
      fun ppf ->
        fake_acc () acc ppf;
        fake_lit lit ppf;

    | C.Acc_formatting_gen (acc, C.Acc_open_tag acc') ->
      fun ppf ->
        fake_acc () acc ppf;
        let (indent, bty) =
          C.open_box_of_string (compute_tag acc') in
        fake_block ppf indent bty ;
    | C.Acc_formatting_gen (acc, C.Acc_open_box acc') ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_open_tag ppf (compute_tag acc')

    | C.Acc_string_literal (acc, s)
    | C.Acc_data_string (acc, s) ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_print_string ppf s;
    | C.Acc_char_literal (acc,c)
    | C.Acc_data_char (acc,c) ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_print_char ppf c;
    | C.Acc_delay (acc, f) ->
      fun ppf ->
        fake_acc () acc ppf;
         F.pp_print_string ppf (f ());
    | C.Acc_flush acc ->
      fun ppf ->
        fake_acc () acc ppf;
        F.pp_print_flush ppf ();
    | C.Acc_invalid_arg (acc,msg) ->
      fun ppf ->
        fake_acc () acc ppf;
        invalid_arg msg
    | C.End_of_acc -> ignore

let printf (CB.Format (fmt, _)) =
  C.make_printf fake_acc () C.End_of_acc fmt

fakeformat.mli

(** Fake Format *)

type ufmt = Format.formatter -> unit
(** Unit printers, to be used with [%t]. **)

val printf : ('a, unit, string, ufmt) format4 -> 'a
(** [printf "..." . . .] returns a unit printer that only contains the
    printing orders. In particular, it only points to raw strings and chars.
    It is, however, still abstract, in the sens that layout and boxes are not
    resolved.
*)