Merge pull request #428 from c-cube/wip-pp

pretty printer

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.22.4
+version = 0.24.1
 profile=conventional
 margin=80
 if-then-else=k-r

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
 

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

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

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))

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))

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 ();

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 "<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"; ext ext_coucou () (sexp_apply "g" [ int 42; int 10 ]) ]
+     in
+     Pretty.to_string ~width:10 d)