diff --git a/.ocamlformat b/.ocamlformat
index c9862378..f820496c 100644
--- a/.ocamlformat
+++ b/.ocamlformat
@@ -1,4 +1,4 @@
-version = 0.22.4
+version = 0.24.1
profile=conventional
margin=80
if-then-else=k-r
diff --git a/Makefile b/Makefile
index 9120f4c0..f77578bd 100644
--- a/Makefile
+++ b/Makefile
@@ -30,7 +30,7 @@ update_next_tag:
sed -i "s/NEXT_VERSION/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli)
sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli)
-WATCH?=@src/all @tests/runtest
+WATCH?=@src/check @tests/runtest
watch:
@dune build $(WATCH) -w
diff --git a/src/pp/containers_pp.ml b/src/pp/containers_pp.ml
new file mode 100644
index 00000000..f10a8f1e
--- /dev/null
+++ b/src/pp/containers_pp.ml
@@ -0,0 +1,467 @@
+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 *)
+ 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
+ { char; sub_string; string; newline }
+
+ let[@inline] char self c = self.char c
+ let[@inline] string self s = self.string s
+ let[@inline] sub_string self s i len = self.sub_string s i len
+ let[@inline] newline self = self.newline ()
+end
+
+module Ext = struct
+ 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 = {
+ view: view; (** Document view *)
+ wfl: int; (** Width if flattened *)
+}
+
+and view =
+ | Nil
+ | Newline
+ | Nest of int * t
+ | Append of t * t
+ | Char of char
+ | Text of string
+ | Text_sub of string * int * int
+ | Text_zero_width of string
+ | Group of t
+ | Fill of { sep: t; l: t list }
+ | Wrap : 'a Ext.t * 'a * t -> view
+
+(* debug printer *)
+let rec debug out (self : t) : unit =
+ match self.view with
+ | Nil -> Format.fprintf out "nil"
+ | Newline -> Format.fprintf out "nl"
+ | Nest (i, x) -> Format.fprintf out "(@[nest %d@ %a@])" i debug x
+ | Append (a, b) -> Format.fprintf out "@[%a ^@ %a@]" debug a debug b
+ | Char c -> Format.fprintf out "%C" c
+ | Text s -> Format.fprintf out "%S" s
+ | Text_zero_width s -> Format.fprintf out "(zw %S)" s
+ | Text_sub (s, i, len) -> Format.fprintf out "%S" (String.sub s i len)
+ | Group d -> Format.fprintf out "(@[group@ %a@])" debug d
+ | Fill { sep = _; l } ->
+ Format.fprintf out "(@[fill@ %a@])" (Format.pp_print_list debug) l
+ | Wrap (_, _, d) -> Format.fprintf out "(@[ext@ %a@])" debug d
+
+let nil : t = { view = Nil; wfl = 0 }
+let newline : t = { view = Newline; wfl = 1 }
+let nl = newline
+
+let char c =
+ if c = '\n' then
+ nl
+ else
+ { view = Char c; wfl = 1 }
+
+let nest i x : t =
+ match x.view with
+ | _ when i <= 0 -> x
+ | Nil -> nil
+ | _ -> { view = Nest (i, x); wfl = x.wfl }
+
+let append a b : t =
+ match a.view, b.view with
+ | Nil, _ -> b
+ | _, Nil -> a
+ | _ -> { view = Append (a, b); wfl = a.wfl + b.wfl }
+
+let group d : t =
+ match d.view with
+ | Nil -> nil
+ | Group _ -> d
+ | _ -> { view = Group d; wfl = d.wfl }
+
+let ext ext v d : t = { view = Wrap (ext, v, d); wfl = d.wfl }
+let ( ^ ) = append
+let text_sub_ s i len : t = { view = Text_sub (s, i, len); wfl = len }
+
+(* Turn [str], which contains some newlines, into a document.
+ We make a concatenation of
+ each line's content followed by a newline.
+ Then we group the result so that it remains in a unified block. *)
+let split_text_ (str : string) : t =
+ let cur = ref nil in
+ let i = ref 0 in
+ let len = String.length str in
+ while !i < len do
+ match String.index_from str !i '\n' with
+ | exception Not_found ->
+ (* last chunk *)
+ if !i + 1 < len then cur := !cur ^ text_sub_ str !i (len - !i);
+ i := len
+ | j ->
+ cur := !cur ^ text_sub_ str !i (j - !i) ^ nl;
+ i := j + 1
+ done;
+ !cur
+
+let text (str : string) : t =
+ if str = "" then
+ nil
+ else if String.contains str '\n' then
+ split_text_ str
+ else
+ { view = Text str; wfl = String.length str }
+
+let textpf fmt = Printf.ksprintf text fmt
+let textf fmt = Format.kasprintf text fmt
+
+module Flatten = struct
+ let to_out (out : Out.t) (self : t) : unit =
+ let rec loop (d : t) =
+ match d.view with
+ | Nil -> ()
+ | Char c -> out.char c
+ | Newline -> out.char ' '
+ | Nest (_, x) -> loop x
+ | Append (x, y) ->
+ loop x;
+ loop y
+ | Text s | Text_zero_width s -> out.string s
+ | Text_sub (s, i, len) -> out.sub_string s i len
+ | Group x -> loop x
+ | Fill { sep; l } ->
+ List.iteri
+ (fun i x ->
+ if i > 0 then loop sep;
+ loop x)
+ l
+ | Wrap (ext, v, d) ->
+ ext.pre out v;
+ loop d;
+ 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;
+ Buffer.contents buf
+end
+
+module Pretty = struct
+ type st = { out: Out.t; width: int }
+
+ (** Add [i] spaces of indentation. *)
+ let add_indent st (i : int) =
+ for _i = 1 to i do
+ st.out.char ' '
+ done
+
+ let rec pp_flatten (st : st) (self : t) : int =
+ match self.view with
+ | Nil -> 0
+ | Char c ->
+ st.out.char c;
+ 1
+ | Newline ->
+ 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 ->
+ st.out.string s;
+ String.length s
+ | Text_zero_width s ->
+ st.out.string s;
+ 0
+ | Text_sub (s, i, len) ->
+ st.out.sub_string s i len;
+ len
+ | Group x -> pp_flatten st x
+ | Fill { sep; l } ->
+ (* print separated by spaces *)
+ let n = ref 0 in
+ List.iteri
+ (fun i x ->
+ if i > 0 then n := !n + pp_flatten st sep;
+ n := !n + pp_flatten st x)
+ l;
+ !n
+ | Wrap (ext, v, d) ->
+ ext.pre st.out v;
+ let n = pp_flatten st d in
+ 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 : st) i =
+ st.out.char '\n';
+ add_indent st i
+
+ (** Print [self] into the buffer.
+ @param k how many chars are already printed on the current line
+ *)
+ let rec pp_rec (st : st) (k : int) (stack : (int * t) list) : unit =
+ match stack with
+ | [] -> ()
+ | (i, d) :: stack_tl ->
+ pp_rec_top st ~k ~i d (fun k -> pp_rec st k stack_tl)
+
+ (** Print [d] at indentation [i], with [k] chars already printed
+ on the current line, then calls [kont] with the
+ new [k]. *)
+ and pp_rec_top st ~k ~i d (kont : int -> unit) : unit =
+ match d.view with
+ | Nil -> kont k
+ | Char c ->
+ st.out.char c;
+ kont (k + 1)
+ | Newline ->
+ pp_newline st i;
+ kont i
+ | Nest (j, x) -> pp_rec_top st ~k ~i:(i + j) x kont
+ | Append (x, y) ->
+ (* print [x], then print [y] *)
+ pp_rec_top st ~k ~i x (fun k -> pp_rec_top st ~k ~i y kont)
+ | Text s ->
+ st.out.string s;
+ kont (k + String.length s)
+ | Text_zero_width s ->
+ st.out.string s;
+ kont k
+ | Text_sub (s, i, len) ->
+ st.out.sub_string s i len;
+ kont (k + len)
+ | Group x ->
+ if fits_flattened st k x then (
+ (* print flattened *)
+ let w_x = pp_flatten st x in
+ assert (w_x = x.wfl);
+ kont (k + w_x)
+ ) else
+ pp_rec_top st ~k ~i x kont
+ | Fill { sep; l } -> pp_fill st ~k ~i sep l kont
+ | Wrap (ext, v, d) ->
+ ext.pre st.out v;
+ pp_rec_top st ~k ~i d (fun k ->
+ ext.post st.out v;
+ kont k)
+
+ and pp_fill st ~k ~i sep l (kont : int -> unit) : unit =
+ (* [k] is the current offset in the line *)
+ let rec loop idx k l =
+ match l with
+ | x :: tl ->
+ if fits_flattened st k x then (
+ (* all flattened *)
+ let w_sep =
+ if idx = 0 then
+ 0
+ else
+ pp_flatten st sep
+ in
+ let w_x = pp_flatten st x in
+ assert (w_x = x.wfl);
+ loop (idx + 1) (k + w_x + w_sep) tl
+ ) else (
+ (* print, followed by a newline and resume filling with [k=i] *)
+ let pp_and_continue k =
+ pp_rec_top st ~k ~i x (fun k -> loop (idx + 1) k tl)
+ in
+ if idx > 0 then
+ (* separator, then item *)
+ pp_rec_top st ~k ~i sep pp_and_continue
+ else
+ pp_and_continue k
+ )
+ | [] -> kont k
+ in
+ loop 0 k l
+
+ 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 based on out *)
+ CCFormat.string_lines out (to_string ~width self)
+end
+
+let pp = Pretty.to_format ~width:80
+
+(* helpers *)
+
+let sp = char ' '
+
+module Infix = struct
+ let ( ^ ) = append
+ let[@inline] ( ^+ ) x y = x ^ sp ^ y
+ let[@inline] ( ^/ ) x y = x ^ nl ^ y
+end
+
+include Infix
+
+let true_ = text "true"
+let false_ = text "false"
+
+let bool b =
+ if b then
+ true_
+ else
+ false_
+
+let int x : t = text (string_of_int x)
+let float x : t = text (string_of_float x)
+let float_hex x : t = textpf "%h" x
+let text_quoted s : t = text (Printf.sprintf "%S" s)
+let text_zero_width s : t = { view = Text_zero_width s; wfl = 0 }
+
+let append_l ?(sep = nil) l =
+ let rec loop = function
+ | [] -> nil
+ | [ x ] -> x
+ | x :: tl -> x ^ sep ^ loop tl
+ in
+ loop l
+
+let append_sp l = append_l ~sep:sp l
+let append_nl l = append_l ~sep:nl l
+
+let fill sep = function
+ | [] -> nil
+ | [ x ] -> x
+ | l ->
+ (* flattened: just like concat *)
+ let wfl =
+ List.fold_left (fun wfl x -> wfl + x.wfl) 0 l
+ + ((List.length l - 1) * sep.wfl)
+ in
+ { view = Fill { sep; l }; wfl }
+
+let fill_map sep f l = fill sep (List.map f l)
+
+let of_list ?(sep = nil) f l =
+ let rec loop = function
+ | [] -> nil
+ | [ x ] -> f x
+ | x :: tl -> f x ^ sep ^ loop tl
+ in
+ loop l
+
+let of_seq ?(sep = nil) f seq : t =
+ let rec loop first seq =
+ match seq () with
+ | Seq.Nil -> nil
+ | Seq.Cons (x, tl) ->
+ let x = f x in
+ (if first then
+ x
+ else
+ sep ^ x)
+ ^ loop false tl
+ in
+ loop true seq
+
+let bracket l d r : t = group (text l ^ nest (String.length l) d ^ text r)
+let bracket2 l d r : t = group (text l ^ nest 2 (nl ^ d) ^ nl ^ text r)
+let sexp_l l : t = char '(' ^ nest 1 (group (append_nl l ^ char ')'))
+let sexp_apply a l : t = sexp_l (text a :: l)
+
+module Dump = struct
+ let list l : t =
+ let sep = char ';' ^ nl in
+ group (char '[' ^ nest 1 (fill sep l) ^ char ']')
+end
+
+module Term_color = struct
+ type color =
+ [ `Black | `Red | `Yellow | `Green | `Blue | `Magenta | `Cyan | `White ]
+
+ type style =
+ [ `FG of color (* foreground *)
+ | `BG of color (* background *)
+ | `Bold
+ | `Reset
+ | `Underline ]
+
+ let int_of_color_ = function
+ | `Black -> 0
+ | `Red -> 1
+ | `Green -> 2
+ | `Yellow -> 3
+ | `Blue -> 4
+ | `Magenta -> 5
+ | `Cyan -> 6
+ | `White -> 7
+
+ let code_of_style : style -> int = function
+ | `FG c -> 30 + int_of_color_ c
+ | `BG c -> 40 + int_of_color_ c
+ | `Bold -> 1
+ | `Reset -> 0
+ | `Underline -> 4
+
+ let spf = Printf.sprintf
+ let string_of_style a = spf "\x1b[%dm" (code_of_style a)
+ let reset = string_of_style `Reset
+
+ let string_of_style_list = function
+ | [] -> reset
+ | [ a ] -> string_of_style a
+ | [ a; b ] -> spf "\x1b[%d;%dm" (code_of_style a) (code_of_style b)
+ | [ a; b; c ] ->
+ spf "\x1b[%d;%d;%dm" (code_of_style a) (code_of_style b) (code_of_style c)
+ | l ->
+ let buf = Buffer.create 32 in
+ let pp_num c = Buffer.add_string buf (string_of_int (code_of_style c)) in
+ Buffer.add_string buf "\x1b[";
+ List.iteri
+ (fun i c ->
+ if i > 0 then Buffer.add_char buf ';';
+ pp_num c)
+ l;
+ Buffer.add_string buf "m";
+ Buffer.contents buf
+
+ (* TODO: handle nested styles *)
+ let ext_style_ : style list Ext.t =
+ {
+ pre = (fun out l -> Out.string out (string_of_style_list l));
+ post = (fun out _l -> Out.string out reset);
+ }
+
+ (** Set the foreground color. *)
+ let color (c : color) (d : t) : t = ext ext_style_ [ `FG c ] d
+
+ (** Set a full style for this document. *)
+ let style_l (l : style list) (d : t) : t = ext ext_style_ l d
+end
diff --git a/src/pp/containers_pp.mli b/src/pp/containers_pp.mli
new file mode 100644
index 00000000..9c669fad
--- /dev/null
+++ b/src/pp/containers_pp.mli
@@ -0,0 +1,253 @@
+(** Pretty printing of documents.
+
+ A document is a structured tree of text with
+ formatting instructions.
+
+ It can be rendered into a string ("pretty printed"),
+ see {!Pretty}.
+
+ This follows Wadler's paper "A prettier printer", but with
+ some changes in the rendering part because we can't rely on lazyness
+ to make the algebraic implementation efficient.
+
+ Some general considerations: the type [t] is the type of documents,
+ a tree with text leaves that is pretty printed within a given width.
+
+ Layout is controlled via the combination of a few primitives:
+ - [newline] will either print a space or a newline. It is similar
+ to {!Format}'s ["@ "] in that sense. A big difference with [Format]
+ is that by default [newline] is actually a newline. It only
+ becomes a space if it's in a [group] small enough to fit
+ in the remainder of the current line.
+ - [group d] tries to write [d] on a single line if there's room.
+ If not, it has no effect.
+ - [nest n d] increases the indentation level inside [d]. Any newline
+ that is rendered as a new line is indented by [n] more spaces (which
+ are cumulative with surrounding [nest] calls).
+ - [append a b] (or [a ^ b]) just prints [a] followed by [b].
+ - [fill d] is a bit like [group] but it will try to cram
+ as much as possible on each line. It is not all-or-nothing
+ like [group].
+*)
+
+(** {2 Core} *)
+
+type t
+(** The type of documents *)
+
+val nil : t
+(** Empty document *)
+
+val char : char -> t
+(** Single char. *)
+
+val text : string -> t
+(** Text. The string will be split on ['\n'], which are replaced
+ by {!newline}. *)
+
+val textpf : ('a, unit, string, t) format4 -> 'a
+(** Text, with a {!Printf}-compatible format.
+
+ For example, [textpf "%d-%d" 4 2] is like [text "4-2"]. *)
+
+val textf : ('a, Format.formatter, unit, t) format4 -> 'a
+(** Text, with a {!Format}-compatible format.
+
+ Note that this will bake-in any formatting done by {!Format}.
+ Newlines introduced by format will become hard newlines
+ in the resulting document. *)
+
+val nest : int -> t -> t
+(** [nest n d] increases indentation by [n] inside [d].
+ If current indentation is [m], then every newline inside [d]
+ will be followed by [n + m] leading spaces. *)
+
+val group : t -> t
+(** Group the documents inside this.
+
+ Newlines immediately inside this group will either
+ render as new lines or as spaces, depending on the width available. *)
+
+val append : t -> t -> t
+(** Concatenation. *)
+
+val newline : t
+(** A line break. *)
+
+val nl : t
+(** Alias for {!newline} *)
+
+val fill : t -> t list -> t
+(** [fill sep l] resembles [group (append_l ~sep l)], except it tries
+ to put as many items of [l] as possible on each line.
+
+ In terms of {!Format}, this is like the hov box. *)
+
+(** {2 Output device} *)
+
+(** 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 *)
+ newline: unit -> unit; (** Output a newline *)
+ }
+
+ val of_buffer : Buffer.t -> t
+ val char : t -> char -> unit
+ val string : t -> string -> unit
+ val sub_string : t -> string -> int -> int -> unit
+ val newline : t -> unit
+end
+
+(** {2 Extensibility} *)
+
+(** Extension node.
+
+ Custom nodes can be used to add user-defined behavior to
+ the rendered output. For example, documents
+ might be annotated with ANSI-terminal colors, or
+ with HTML tags. *)
+module Ext : sig
+ type 'a t = {
+ pre: Out.t -> 'a -> unit; (** Printed before the wrapped value. *)
+ post: Out.t -> 'a -> unit; (** Printed after the wrapped value. *)
+ }
+ (** An extension is a custom document node. It takes a value of type ['a],
+ and a document [d], and can output what it wants based
+ on the custom value before and after [d] is printed.
+
+ The extension is considered to have width [0]. *)
+end
+
+val ext : 'a Ext.t -> 'a -> t -> t
+(** [ext e v d] wraps [d] with value [v].
+
+ It is a document that has the same
+ shape (and size) as [d], except that additional data will
+ be output when it is rendered using extension [e].
+
+ When this is rendered, first [e.pre out v] is called;
+ then [d] is printed; then [e.post out v] is called.
+ Here [out] is the output buffer/stream for rendering.
+
+*)
+
+(** {2 Pretty print and rendering} *)
+
+(** Pretty-printing.
+
+ 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. *)
+
+ val to_buffer : width:int -> Buffer.t -> t -> unit
+ (** Render to a buffer. *)
+
+ val to_format : width:int -> Format.formatter -> t -> unit
+end
+
+(** Trivial printing, on a single line.
+
+ 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
+
+val pp : Format.formatter -> t -> unit
+(** Pretty-print, using {!Pretty} and an unspecified margin. *)
+
+val debug : Format.formatter -> t -> unit
+(** Debug printer. This prints the structure of the document,
+ it does {b not} pretty-print it. See {!pp} or {!Pretty}. *)
+
+(** {2 Convenience functions} *)
+
+module Infix : sig
+ val ( ^ ) : t -> t -> t
+ (** Alias of {!append}. *)
+
+ val ( ^+ ) : t -> t -> t
+ (** [x ^+ y] is [x ^ text " " ^ y] *)
+
+ val ( ^/ ) : t -> t -> t
+ (** [x ^/ y] is [x ^ newline ^ y] *)
+end
+
+include module type of Infix
+
+val sp : t
+(** A single space *)
+
+val append_l : ?sep:t -> t list -> t
+(** [append_l ?sep l] is the concatenation of elements of
+ [l], separated by [sep] (default [nil]) *)
+
+val append_sp : t list -> t
+(** [append_sp l] is the concatenation of elements of [l], separated by [' '] *)
+
+val append_nl : t list -> t
+(** Same as {!append_l} with [sep=nl] *)
+
+val fill_map : t -> ('a -> t) -> 'a list -> t
+(** [fill_map sep f l] is [fill sep (List.map f l)] *)
+
+val bool : bool -> t
+val int : int -> t
+val float : float -> t
+val float_hex : float -> t
+
+val text_quoted : string -> t
+(** [text_quoted s] is [text (spf "%S" s)] *)
+
+val text_zero_width : string -> t
+(** Text but we assume it takes no space on screen. *)
+
+val of_list : ?sep:t -> ('a -> t) -> 'a list -> t
+(** [of_list f l] maps each element of [l] to a document
+ and concatenates them.
+ @param sep separator inserted between elements (default [nil]) *)
+
+val of_seq : ?sep:t -> ('a -> t) -> 'a Seq.t -> t
+(** Same as {!of_list} but with sequences. *)
+
+val bracket : string -> t -> string -> t
+(** [bracket l d r] groups [d], between brackets [l] and [r] *)
+
+val bracket2 : string -> t -> string -> t
+(** [bracket2 l d r] groups [d], indented by 2, between brackets [l] and [r] *)
+
+val sexp_apply : string -> t list -> t
+(** [sexp_apply a l] is the S-expr ["(text a …l)"], pretty-printed *)
+
+val sexp_l : t list -> t
+(** [sexp_l [l1;…ln]] is the S-expr ["(l1 l2…ln)"], pretty-printed *)
+
+(** Printers that correspond closely to OCaml's syntax. *)
+module Dump : sig
+ val list : t list -> t
+end
+
+(** Simple colors in terminals *)
+module Term_color : sig
+ type color =
+ [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ]
+
+ type style = [ `BG of color | `Bold | `FG of color | `Reset | `Underline ]
+
+ val color : color -> t -> t
+ val style_l : style list -> t -> t
+end
diff --git a/src/pp/dune b/src/pp/dune
new file mode 100644
index 00000000..fbf9d1fb
--- /dev/null
+++ b/src/pp/dune
@@ -0,0 +1,7 @@
+
+(library
+ (name containers_pp)
+ (public_name containers.pp)
+ (synopsis "Pretty printer for Containers")
+ (flags :standard)
+ (libraries containers seq))
diff --git a/src/cbor/tests/appendix_a.json b/tests/cbor/appendix_a.json
similarity index 100%
rename from src/cbor/tests/appendix_a.json
rename to tests/cbor/appendix_a.json
diff --git a/src/cbor/tests/dune b/tests/cbor/dune
similarity index 100%
rename from src/cbor/tests/dune
rename to tests/cbor/dune
diff --git a/src/cbor/tests/t_appendix_a.ml b/tests/cbor/t_appendix_a.ml
similarity index 100%
rename from src/cbor/tests/t_appendix_a.ml
rename to tests/cbor/t_appendix_a.ml
diff --git a/tests/core/dune b/tests/core/dune
index e17dd3a6..89c12c06 100644
--- a/tests/core/dune
+++ b/tests/core/dune
@@ -6,5 +6,6 @@
(preprocess
(action
(run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
- (libraries containers containers.bencode containers.cbor containers.unix
+ (libraries containers containers.bencode containers.cbor
+ containers.unix containers.pp
threads containers_testlib iter gen uutf csexp))
diff --git a/tests/core/t.ml b/tests/core/t.ml
index e5d27999..8508555a 100644
--- a/tests/core/t.ml
+++ b/tests/core/t.ml
@@ -1,5 +1,6 @@
Containers_testlib.run_all ~descr:"containers"
[
+ T_pp.get ();
T_list.get ();
T_array.get ();
T_bool.get ();
diff --git a/tests/core/t_pp.ml b/tests/core/t_pp.ml
new file mode 100644
index 00000000..747cde5a
--- /dev/null
+++ b/tests/core/t_pp.ml
@@ -0,0 +1,61 @@
+include (val Containers_testlib.make ~__FILE__ ())
+open Containers_pp
+
+let spf = Printf.sprintf
+
+let () =
+ eq "hello world" (Flatten.to_string @@ text "hello" ^ newline ^ text "world")
+
+let () =
+ eq ~name:"split text" ~printer:(spf "%S") "let rec f x =\n x+2\n"
+ (let d = text "let rec f x =\n x+2\n" in
+ Pretty.to_string ~width:15 d)
+
+let () =
+ eq ~name:"l1" ~printer:(spf "%S") "[0; 1; 2; 3;\n 4; 5; 6; 7;\n 8; 9]"
+ (let d = Dump.list (CCList.init 10 int) in
+ Pretty.to_string ~width:10 d)
+
+let () =
+ eq ~name:"l2" ~printer:(spf "%S")
+ "[[0; 1; 2; 3;\n\
+ \ 4; 5];\n\
+ \ [1; 2; 3; 4;\n\
+ \ 5; 6];\n\
+ \ [2; 3; 4; 5;\n\
+ \ 6; 7];\n\
+ \ [3; 4; 5; 6;\n\
+ \ 7; 8];\n\
+ \ [4; 5; 6; 7;\n\
+ \ 8; 9];\n\
+ \ [5; 6; 7; 8;\n\
+ \ 9; 10]]"
+ (let d =
+ Dump.list
+ (CCList.init 6 (fun i ->
+ Dump.list (CCList.init 6 (fun j -> int @@ (i + j)))))
+ in
+ Pretty.to_string ~width:10 d)
+
+let () =
+ eq ~name:"s1" ~printer:(spf "%S") "(foo\n bar\n baaz\n (g 42 10))"
+ (let d =
+ sexp_apply "foo"
+ [ text "bar"; text "baaz"; sexp_apply "g" [ int 42; int 10 ] ]
+ in
+ Pretty.to_string ~width:10 d)
+
+let ext_coucou =
+ {
+ Ext.pre = (fun out () -> out.string "");
+ post = (fun out () -> out.string "");
+ }
+
+let () =
+ eq ~name:"wrap1" ~printer:(spf "%S")
+ "(foo\n bar\n (g 42 10))"
+ (let d =
+ sexp_apply "foo"
+ [ text "bar"; ext ext_coucou () (sexp_apply "g" [ int 42; int 10 ]) ]
+ in
+ Pretty.to_string ~width:10 d)