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

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

43
src/pp/containers_pp.mli
View file

@ -55,27 +55,32 @@ val newline : t
val nl : t val nl : t
(** Alias for {!newline} *) (** 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. (** Extension node.
In here, we can stuff custom printer nodes. *) In here, we can stuff custom printer nodes. *)
module Ext : sig module Ext : sig
module type OUT = sig type 'a t = {
val char : char -> unit pre: Out.t -> 'a -> unit; (** Printed before the wrapped value. *)
val sub_string : string -> int -> int -> unit post: Out.t -> 'a -> unit; (** Printed after the wrapped value. *)
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)
end end
val wrap : 'a Ext.t -> 'a -> t -> t 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, These functions are parametrized by a width,
and will try to fit the result within this width. *) and will try to fit the result within this width. *)
module Pretty : sig module Pretty : sig
val to_out : width:int -> Out.t -> t -> unit
(** Render to an arbitrary output. *)
val to_string : width:int -> t -> string val to_string : width:int -> t -> string
(** Render to a string. *) (** Render to a string. *)
@ -113,6 +121,7 @@ end
This is generally ugly, but it's simple and fast when we do not This is generally ugly, but it's simple and fast when we do not
care about looks. *) care about looks. *)
module Flatten : sig module Flatten : sig
val to_out : Out.t -> t -> unit
val to_buffer : Buffer.t -> t -> unit val to_buffer : Buffer.t -> t -> unit
val to_string : t -> string val to_string : t -> string
end end

16
tests/core/t_pp.ml
View file

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