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