Lwt_fmt.ml

open Lwt.Infix

type order =
  | String of string * int * int
  | Flush

let write_order oc = function
  | String (s, i, j) ->
    Lwt_io.write_from_string_exactly oc s i j
  | Flush ->
    Lwt_io.flush oc

type formatter = {
  write : unit -> unit Lwt.t ;
  ppf : Format.formatter ;
}

let rec write_orders oc stream =
  Lwt_stream.get stream >>= fun order ->
  match order with
  | Some o ->
    write_order oc o >>= fun () ->
    write_orders oc stream
  | None -> Lwt.return_unit

(* Low level function *)
let make_formatter () =
  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 ppf = Format.make_formatter out_string flush in
  stream, ppf

(** Exposed functions *)

let of_channel oc =
  let stream, ppf = make_formatter () in
  let write () = write_orders oc stream in
  { write ; ppf }

let make_stream () =
  let stream, ppf = make_formatter () in
  let write () = Lwt.return_unit in
  stream, { write ; ppf }


let write_pending ppft = ppft.write ()
let flush ppft = Format.pp_print_flush ppft.ppf () ; ppft.write ()
 
let kfprintf k ppft fmt =
  Format.kfprintf (fun ppf -> k ppf @@ ppft.write ()) ppft.ppf fmt

let fprintf ppft fmt =
  kfprintf (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

Lwt_fmt.mli

type formatter
(** Lwt enabled formatters *)

val of_channel : Lwt_io.output_channel -> formatter

val stdout : formatter
val stderr : formatter

val printf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val eprintf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val fprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val kfprintf :
  (Format.formatter -> unit Lwt.t -> 'a) ->
  formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b



val flush : formatter -> unit Lwt.t

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. You should probably use {!flush} instead.
*)