annotate lib/print.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
mike@0 1 (* lib/print.ml *)
mike@0 2 (* Copyright (c) 2017 J. M. Spivey *)
mike@0 3
mike@0 4 type arg = vtable -> unit
mike@0 5
mike@0 6 and vtable = { outch : char -> unit; prf : string -> arg list -> unit }
mike@0 7
mike@0 8 (* |do_print| -- the guts of printf and friends *)
mike@0 9 let rec do_print outch fmt args0 =
mike@0 10 let vtab = { outch = outch; prf = do_print outch } in
mike@0 11 let args = ref args0 in
mike@0 12 for i = 0 to String.length fmt - 1 do
mike@0 13 if fmt.[i] <> '$' then
mike@0 14 outch fmt.[i]
mike@0 15 else begin
mike@0 16 try
mike@0 17 List.hd !args vtab;
mike@0 18 args := List.tl !args
mike@0 19 with
mike@0 20 Invalid_argument _ ->
mike@0 21 outch '*'; outch '*'; outch '*'
mike@0 22 end
mike@0 23 done
mike@0 24
mike@0 25 let fChr ch vt = vt.outch ch
mike@0 26 let fStr s vt =
mike@0 27 for i = 0 to String.length s - 1 do vt.outch s.[i] done
mike@0 28
mike@0 29 let fNum n = fStr (string_of_int n)
mike@0 30 let fFlo x = fStr (string_of_float x)
mike@0 31 let fBool b = fStr (if b then "true" else "false")
mike@0 32 let fExt g vt = g vt.prf
mike@0 33
mike@0 34 let fFix (n, w) =
mike@0 35 let digits = string_of_int n in
mike@0 36 let w0 = String.length digits in
mike@0 37 let padding = if w0 >= w then "" else String.make (w-w0) ' ' in
mike@0 38 fStr (padding ^ digits)
mike@0 39
mike@0 40 (* |fMeta| -- insert output of recursive call to printf *)
mike@0 41 let fMeta fmt args = fExt (function prf -> prf fmt args)
mike@0 42
mike@0 43 (* |fList| -- format a comma-separated list *)
mike@0 44 let fList cvt xs =
mike@0 45 let f prf =
mike@0 46 if xs <> [] then begin
mike@0 47 prf "$" [cvt (List.hd xs)];
mike@0 48 List.iter (function y -> prf ", $" [cvt y]) (List.tl xs)
mike@0 49 end in
mike@0 50 fExt f
mike@0 51
mike@0 52 (* |fprintf| -- print to a file *)
mike@0 53 let fprintf fp fmt args = do_print (output_char fp) fmt args
mike@0 54
mike@0 55 (* |printf| -- print on standard output *)
mike@0 56 let printf fmt args = fprintf stdout fmt args; flush stdout
mike@0 57
mike@0 58 (* |sprintf| -- print to a string *)
mike@0 59 let sprintf fmt args =
mike@0 60 let buf = Buffer.create 16 in
mike@0 61 do_print (Buffer.add_char buf) fmt args;
mike@0 62 Buffer.contents buf
mike@0 63
mike@0 64 open Format
mike@0 65
mike@0 66 let rec do_grind fmt args0 =
mike@0 67 let vtab = { outch = print_char; prf = do_grind } in
mike@0 68 let args = ref args0 in
mike@0 69 for i = 0 to String.length fmt - 1 do
mike@0 70 let ch = fmt.[i] in
mike@0 71 match ch with
mike@0 72 '$' ->
mike@0 73 begin try
mike@0 74 List.hd !args vtab;
mike@0 75 args := List.tl !args
mike@0 76 with
mike@0 77 Invalid_argument _ -> print_string "***"
mike@0 78 end
mike@0 79 | ' ' -> print_space ()
mike@0 80 | '_' -> print_char ' '
mike@0 81 | '(' | '<' | '[' -> open_hvbox 2; print_char ch
mike@0 82 | ')' | '>' | ']' -> print_char ch; close_box ()
mike@0 83 | ch -> print_char ch
mike@0 84 done
mike@0 85
mike@0 86 (* |fgrindf| -- pretty-printer *)
mike@0 87 let rec fgrindf fp pfx fmt args =
mike@0 88 let plen = String.length pfx in
mike@0 89 set_formatter_out_channel fp;
mike@0 90 let funs = get_formatter_out_functions () in
mike@0 91 let newline1 () = funs.out_newline (); funs.out_string pfx 0 plen in
mike@0 92 set_formatter_out_functions { funs with out_newline = newline1 };
mike@0 93 funs.out_string pfx 0 plen;
mike@0 94 open_hvbox 2;
mike@0 95 do_grind fmt args;
mike@0 96 close_box();
mike@0 97 print_flush ();
mike@0 98 set_formatter_out_functions funs;
mike@0 99 print_newline ()