Lwt_fmt

src/unix/Lwt_fmt.ml

@@ -0,0 +1,98 @@
+(* OCaml promise library
+ * http://www.ocsigen.org/lwt
+ * Copyright (C) 2018 Gabriel Radanne
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as
+ * published by the Free Software Foundation, with linking exceptions;
+ * either version 2.1 of the License, or (at your option) any later
+ * version. See COPYING file for details.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ * 02111-1307, USA.
+ *)
+
+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
+  (* Not sure about that one *)
+  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.stdout
+
+let printf fmt = fprintf stdout fmt
+let eprintf fmt = fprintf stderr fmt

src/unix/Lwt_fmt.mli

@@ -0,0 +1,104 @@
+(* OCaml promise library
+ * http://www.ocsigen.org/lwt
+ * Copyright (C) 2018 Gabriel Radanne
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as
+ * published by the Free Software Foundation, with linking exceptions;
+ * either version 2.1 of the License, or (at your option) any later
+ * version. See COPYING file for details.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ * 02111-1307, USA.
+ *)
+
+(** Format API for Lwt-powered IOs *)
+
+(** This module bridges the gap between {!Format} and {!Lwt}.
+    Although it is not required, it is recommended to use this module with the
+    {!Fmt} library.
+
+    Compared to regular formatting function, the main difference is that
+    printing statements will now return promises instead of blocking.
+*)
+
+val printf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+(** Returns a promise that prints on the standard output. 
+    Similar to {!Format.printf}. *)
+
+val eprintf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+(** Returns a promise that prints on the standard error. 
+    Similar to {!Format.eprintf}. *)
+
+(** {1 Formatters} *)
+
+type formatter
+(** Lwt enabled formatters *)
+
+type order =
+  | String of string * int * int (** [String (s, off, len)] indicate the output of [s] at offset [off] and length [len]. *)
+  | Flush (** Flush operation *)
+
+val make_stream : unit -> order Lwt_stream.t * formatter
+(** [make_stream ()] returns a formatter and a stream of all the writing
+    order given on that stream.
+*)
+
+
+val of_channel : Lwt_io.output_channel -> formatter
+(** [of_channel oc] creates a formatter that writes to the channel [oc]. *)
+
+val stdout : formatter (** Formatter printing on {!Lwt_io.stdout}. *)
+val stderr : formatter (** Formatter printing on {!Lwt_io.stdout}. *)
+
+val make_formatter :
+  commit:(unit -> unit Lwt.t) -> fmt:Format.formatter -> unit -> formatter
+(** [make_formatter ~commit ~fmt] creates a new lwt formatter based on the
+    {!Format.formatter} [fmt]. The [commit] function will be called by the printing
+    functions to update the underlying channel.
+*)
+
+val get_formatter : formatter -> Format.formatter
+(** [get_formatter fmt] returns the underlying {!Format.formatter}. 
+    To access the underlying formatter during printing, it is
+    recommended to use [%t] and [%a].
+*)
+
+(** {2 Printing} *)
+
+val fprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+
+val kfprintf :
+  (formatter -> unit Lwt.t -> 'a) ->
+  formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+
+val ifprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+
+val ikfprintf :
+  (formatter -> unit Lwt.t -> 'a) ->
+  formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+
+val flush : formatter -> unit Lwt.t
+(** [flush fmt] flushes the formatter (as with {!Format.pp_print_flush}) and
+    executes all the printing action on the underlying channel.
+*)
+
+
+(** Low level functions *)
+
+val write_order : Lwt_io.output_channel -> order -> unit Lwt.t
+(** [write_order oc o] applies the order [o] on the channel [oc]. *)
+
+val write_pending : formatter -> unit Lwt.t
+(** Write all the pending orders of a formatter.
+    Warning: This function flush neither the internal format queues
+    nor the underlying channel and is intended for low level use only. 
+    You should probably use {!flush} instead.
+*)

test/unix/main.ml

@@ -48,4 +48,5 @@ let () =
     Test_lwt_process.suite;
     Test_lwt_engine.suite;
     Test_mcast.suite;
+    Test_lwt_fmt.suite;
   ]

test/unix/test_lwt_fmt.ml

@@ -0,0 +1,78 @@
+(* OCaml promise library
+ * http://www.ocsigen.org/lwt
+ * Copyright (C) 2018 Gabriel Radanne
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as
+ * published by the Free Software Foundation, with linking exceptions;
+ * either version 2.1 of the License, or (at your option) any later
+ * version. See COPYING file for details.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ * 02111-1307, USA.
+ *)
+
+open Test
+open Lwt.Infix
+
+let testchan () =
+  let b = Buffer.create 6 in
+  let f buf ofs len = 
+    let bytes = Bytes.create len in
+    Lwt_bytes.blit_to_bytes buf ofs bytes 0 len;
+    Buffer.add_bytes b bytes;
+    Lwt.return len
+  in
+  let oc = Lwt_io.make ~mode:Output f in
+  let fmt = Lwt_fmt.of_channel oc in
+  fmt, (fun () -> Buffer.contents b)
+
+let suite = suite "lwt_fmt" [
+    test "flushing" (fun () -> 
+        let fmt, f = testchan () in
+        Lwt_fmt.fprintf fmt "%s%i%s%!" "bla" 3 "blo" >>= fun () ->
+        Lwt.return (f () = {|bla3blo|})
+      );
+    test "with combinator" (fun () -> 
+        let fmt, f = testchan () in
+        Lwt_fmt.fprintf fmt "%a%!" Format.pp_print_int 3 >>= fun () ->
+        Lwt.return (f () = {|3|})
+      );
+    test "box" (fun () -> 
+        let fmt, f = testchan () in
+        Lwt_fmt.fprintf fmt "@[<v2>%i@,%i@]%!" 1 2 >>= fun () ->
+        Lwt.return (f () = "1\n  2")
+      );
+    test "boxsplit" (fun () -> 
+        let fmt, f = testchan () in
+        Lwt_fmt.fprintf fmt "@[<v2>%i" 1 >>= fun () ->
+        Lwt_fmt.fprintf fmt "@,%i@]" 2 >>= fun () ->
+        Lwt_fmt.flush fmt >>= fun () ->
+        Lwt.return (f () = "1\n  2")
+      );
+    test "box close with flush" (fun () -> 
+        let fmt, f = testchan () in
+        Lwt_fmt.fprintf fmt "@[<v2>%i" 1 >>= fun () ->
+        Lwt_fmt.fprintf fmt "@,%i" 2 >>= fun () ->
+        Lwt_fmt.flush fmt >>= fun () ->
+        Lwt.return (f () = "1\n  2")
+      );
+
+    test "stream"  (fun () -> 
+        let stream, fmt = Lwt_fmt.make_stream () in
+        Lwt_fmt.fprintf fmt "@[<v2>%i@,%i@]%!" 1 2 >>= fun () ->
+        Lwt.return (Lwt_stream.get_available stream = [
+            String ("1", 0, 1);
+            String ("\n", 0, 1);
+            String  ("                                                                                ", 0, 2);
+            String ("2", 0, 1);
+            Flush])
+      );
+  ]