Skip to content

Instantly share code, notes, and snippets.

@Drup
Created April 10, 2017 17:31
Show Gist options
  • Save Drup/22e33eda1ebb33b0073d256aa5935e6f to your computer and use it in GitHub Desktop.
Save Drup/22e33eda1ebb33b0073d256aa5935e6f to your computer and use it in GitHub Desktop.
Fake printer
[@@@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
(** 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.
*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment