simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-07 03:35:30 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Pp: expose generic output; simplify extensions

Browse source
This commit is contained in:
Simon Cruanes 2023-03-30 23:33:01 -04:00
parent d36c57459e
commit 4d77a17029
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
3 changed files with 93 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

119
src/pp/containers_pp.ml
View file

@ -1,31 +1,31 @@
module B = Buffer
module Out = struct
type t = {
char: char -> unit;
(** Output a single char. The char is assumed not to be ['\n']. *)
sub_string: string -> int -> int -> unit;
(** Output a string slice (optim for [string]) *)
string: string -> unit; (** Output a string *)
raw_string: string -> unit;
(** Output a string that should not be modified in any way *)
newline: unit -> unit; (** Output a newline *)
}
let of_buffer (buf : Buffer.t) : t =
let char = B.add_char buf in
let sub_string = B.add_substring buf in
let string = B.add_string buf in
let newline () = B.add_char buf '\n' in
let raw_string = string in
{ char; sub_string; string; newline; raw_string }
end
module Ext = struct
module type OUT = sig
val char : char -> unit
val sub_string : string -> int -> int -> unit
val string : string -> unit
val newline : unit -> unit
end
type out = (module OUT)
let out_of_buf (buf : Buffer.t) : out =
(module struct
let char = B.add_char buf
let sub_string = B.add_substring buf
let string = B.add_string buf
let newline () = B.add_char buf '\n'
end)
module type S = sig
type t
val pre : out -> t -> unit
val post : out -> t -> unit
end
type 'a t = (module S with type t = 'a)
type 'a t = {
pre: Out.t -> 'a -> unit; (** Printed before the wrapped value. *)
post: Out.t -> 'a -> unit; (** Printed after the wrapped value. *)
}
end
type t = {
@ -109,18 +109,18 @@ let textpf fmt = Printf.ksprintf text fmt
let textf fmt = Format.kasprintf text fmt
module Flatten = struct
let to_buffer buf (self : t) : unit =
let to_out (out : Out.t) (self : t) : unit =
let rec loop (d : t) =
match d.view with
| Nil -> ()
| Char c -> B.add_char buf c
| Newline -> B.add_char buf ' '
| Char c -> out.char c
| Newline -> out.char ' '
| Nest (_, x) -> loop x
| Append (x, y) ->
loop x;
loop y
| Text s -> B.add_string buf s
| Text_sub (s, i, len) -> B.add_substring buf s i len
| Text s -> out.string s
| Text_sub (s, i, len) -> out.sub_string s i len
| Group x -> loop x
| Fill { sep; l } ->
List.iteri
@ -128,15 +128,17 @@ module Flatten = struct
if i > 0 then loop sep;
loop x)
l
| Wrap ((module E), v, d) ->
let out = Ext.out_of_buf buf in
E.pre out v;
| Wrap (ext, v, d) ->
ext.pre out v;
loop d;
E.post out v
ext.post out v
in
loop self
let to_buffer buf (self : t) : unit =
let out = Out.of_buffer buf in
to_out out self
let to_string self : string =
let buf = Buffer.create 32 in
to_buffer buf self;
@ -144,32 +146,32 @@ module Flatten = struct
end
module Pretty = struct
type st = { buf: Buffer.t; width: int }
type st = { out: Out.t; width: int }
(** Add [i] spaces of indentation. *)
let add_indent (st : st) (i : int) =
let add_indent st (i : int) =
for _i = 1 to i do
B.add_char st.buf ' '
st.out.char ' '
done
let rec pp_flatten (st : st) (self : t) : int =
match self.view with
| Nil -> 0
| Char c ->
B.add_char st.buf c;
st.out.char c;
1
| Newline ->
B.add_char st.buf ' ';
st.out.char ' ';
1
| Nest (_i, x) -> pp_flatten st x
| Append (x, y) ->
let n = pp_flatten st x in
n + pp_flatten st y
| Text s ->
B.add_string st.buf s;
st.out.string s;
String.length s
| Text_sub (s, i, len) ->
B.add_substring st.buf s i len;
st.out.sub_string s i len;
len
| Group x -> pp_flatten st x
| Fill { sep; l } ->
@ -181,19 +183,18 @@ module Pretty = struct
n := !n + pp_flatten st x)
l;
!n
| Wrap ((module E), v, d) ->
let out = Ext.out_of_buf st.buf in
E.pre out v;
| Wrap (ext, v, d) ->
ext.pre st.out v;
let n = pp_flatten st d in
E.post out v;
ext.post st.out v;
n
(** Does [x] fit in the current line when flattened, given that [k] chars
are already on the line? *)
let[@inline] fits_flattened st k x = x.wfl <= st.width - k
let pp_newline st i =
B.add_char st.buf '\n';
let pp_newline (st : st) i =
st.out.char '\n';
add_indent st i
(** Print [self] into the buffer.
@ -212,7 +213,7 @@ module Pretty = struct
match d.view with
| Nil -> kont k
| Char c ->
B.add_char st.buf c;
st.out.char c;
kont (k + 1)
| Newline ->
pp_newline st i;
@ -222,10 +223,10 @@ module Pretty = struct
(* print [x], then print [y] *)
pp_rec_top st ~k ~i x (fun k -> pp_rec_top st ~k ~i y kont)
| Text s ->
B.add_string st.buf s;
st.out.string s;
kont (k + String.length s)
| Text_sub (s, i, len) ->
B.add_substring st.buf s i len;
st.out.sub_string s i len;
kont (k + len)
| Group x ->
if fits_flattened st k x then (
@ -236,11 +237,10 @@ module Pretty = struct
) else
pp_rec_top st ~k ~i x kont
| Fill { sep; l } -> pp_fill st ~k ~i sep l kont
| Wrap ((module E), v, d) ->
let out = Ext.out_of_buf st.buf in
E.pre out v;
| Wrap (ext, v, d) ->
ext.pre st.out v;
pp_rec_top st ~k ~i d (fun k ->
E.post out v;
ext.post st.out v;
kont k)
and pp_fill st ~k ~i sep l (kont : int -> unit) : unit =
@ -274,17 +274,20 @@ module Pretty = struct
in
loop 0 k l
let to_buffer ~width (buf : Buffer.t) (self : t) : unit =
let st = { buf; width } in
let to_out ~width out (self : t) : unit =
let st = { out; width } in
pp_rec st 0 [ 0, self ]
let to_buffer ~width (buf : Buffer.t) (self : t) : unit =
to_out ~width (Out.of_buffer buf) self
let to_string ~width (self : t) : string =
let buf = Buffer.create 32 in
to_buffer ~width buf self;
Buffer.contents buf
let to_format ~width out self : unit =
(* TODO: more efficient implementation *)
(* TODO: more efficient implementation based on out *)
CCFormat.string_lines out (to_string ~width self)
end

43
src/pp/containers_pp.mli
View file

@ -55,27 +55,32 @@ val newline : t
val nl : t
(** Alias for {!newline} *)
(** Arbitrary output.
This is used for user-provided output. *)
module Out : sig
type t = {
char: char -> unit;
(** Output a single char. The char is assumed not to be ['\n']. *)
sub_string: string -> int -> int -> unit;
(** Output a string slice (optim for [string]) *)
string: string -> unit; (** Output a string *)
raw_string: string -> unit;
(** Output a string that should not be modified in any way *)
newline: unit -> unit; (** Output a newline *)
}
val of_buffer : Buffer.t -> t
end
(** Extension node.
In here, we can stuff custom printer nodes. *)
module Ext : sig
module type OUT = sig
val char : char -> unit
val sub_string : string -> int -> int -> unit
val string : string -> unit
val newline : unit -> unit
end
type out = (module OUT)
module type S = sig
type t
val pre : out -> t -> unit
val post : out -> t -> unit
end
type 'a t = (module S with type t = 'a)
type 'a t = {
pre: Out.t -> 'a -> unit; (** Printed before the wrapped value. *)
post: Out.t -> 'a -> unit; (** Printed after the wrapped value. *)
}
end
val wrap : 'a Ext.t -> 'a -> t -> t
@ -99,6 +104,9 @@ val wrap : 'a Ext.t -> 'a -> t -> t
These functions are parametrized by a width,
and will try to fit the result within this width. *)
module Pretty : sig
val to_out : width:int -> Out.t -> t -> unit
(** Render to an arbitrary output. *)
val to_string : width:int -> t -> string
(** Render to a string. *)
@ -113,6 +121,7 @@ end
This is generally ugly, but it's simple and fast when we do not
care about looks. *)
module Flatten : sig
val to_out : Out.t -> t -> unit
val to_buffer : Buffer.t -> t -> unit
val to_string : t -> string
end

16
tests/core/t_pp.ml
View file

@ -40,21 +40,17 @@ let () =
in
Pretty.to_string ~width:10 d)
module Ext_coucou : Ext.S with type t = unit = struct
type t = unit
let pre (module O : Ext.OUT) () = O.string "<coucou>"
let post (module O : Ext.OUT) () = O.string "</coucou>"
end
let ext_coucou =
{
Ext.pre = (fun out () -> out.string "<coucou>");
post = (fun out () -> out.string "</coucou>");
}
let () =
eq ~name:"wrap1" ~printer:(spf "%S")
"(foo\n bar\n <coucou>(g 42 10)</coucou>)"
(let d =
sexp_apply "foo"
[
text "bar";
wrap (module Ext_coucou) () (sexp_apply "g" [ int 42; int 10 ]);
]
[ text "bar"; wrap ext_coucou () (sexp_apply "g" [ int 42; int 10 ]) ]
in
Pretty.to_string ~width:10 d)