1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
open Lwt.Infix
type formatter = {
commit : unit -> unit Lwt.t ;
fmt : Format.formatter ;
}
let write_pending ppft = ppft.commit ()
let flush ppft = Format.pp_print_flush ppft.fmt () ; ppft.commit ()
let make_formatter ~commit ~fmt () = { commit ; fmt }
let get_formatter x = x.fmt
(** Stream formatter *)
type order =
| String of string * int * int
| Flush
let make_stream () =
let stream, push = Lwt_stream.create () in
let out_string s i j =
push @@ Some (String (s, i, j))
and flush () =
push @@ Some Flush
in
let fmt = Format.make_formatter out_string flush in
Gc.finalise (fun _ -> push None) fmt ;
let commit () = Lwt.return_unit in
stream, make_formatter ~commit ~fmt ()
(** Channel formatter *)
let write_order oc = function
| String (s, i, j) ->
Lwt_io.write_from_string_exactly oc s i j
| Flush ->
Lwt_io.flush oc
let rec write_orders oc queue =
if Queue.is_empty queue then
Lwt.return_unit
else
let o = Queue.pop queue in
write_order oc o >>= fun () ->
write_orders oc queue
let of_channel oc =
let q = Queue.create () in
let out_string s i j =
Queue.push (String (s, i, j)) q
and flush () =
Queue.push Flush q
in
let fmt = Format.make_formatter out_string flush in
let commit () = write_orders oc q in
make_formatter ~commit ~fmt ()
(** Printing functions *)
let kfprintf k ppft fmt =
Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) ppft.fmt fmt
let ikfprintf k ppft fmt =
Format.ikfprintf (fun _ppf -> k ppft @@ Lwt.return_unit) ppft.fmt fmt
let fprintf ppft fmt =
kfprintf (fun _ t -> t) ppft fmt
let ifprintf ppft fmt =
ikfprintf (fun _ t -> t) ppft fmt
let stdout = of_channel Lwt_io.stdout
let stderr = of_channel Lwt_io.stderr
let printf fmt = fprintf stdout fmt
let eprintf fmt = fprintf stderr fmt