From 65fc9204270bc84381413303c3d7d1b152a7c1f1 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Mon, 19 Aug 2024 12:17:58 -0400
Subject: [PATCH] feat pp: add a bunch of extensions

thanks to @grayswandyr
---
 src/pp/containers_pp.ml  | 55 +++++++++++++++++++++++++++++++++++
 src/pp/containers_pp.mli | 62 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 117 insertions(+)

diff --git a/src/pp/containers_pp.ml b/src/pp/containers_pp.ml
index 6724a511..621b7ecf 100644
--- a/src/pp/containers_pp.ml
+++ b/src/pp/containers_pp.ml
@@ -1,6 +1,8 @@
 module B = Buffer
 module Int_map = Map.Make (CCInt)
 
+type 'a iter = ('a -> unit) -> unit
+
 module Out = struct
   type t = {
     char: char -> unit;
@@ -464,11 +466,64 @@ 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)
+let surround ?(width = 1) l b r = group (l ^ nest width b ^ r)
+
+module Char = struct
+  let bang = char '!'
+  let at = char '@'
+  let hash = char '#'
+  let dollar = char '$'
+  let tilde = char '~'
+  let backquote = char '`'
+  let percent = char '%'
+  let caret = char '^'
+  let ampersand = char '&'
+  let star = char '*'
+  let minus = char '-'
+  let underscore = char '_'
+  let plus = char '+'
+  let equal = char '='
+  let pipe = char '|'
+  let slash = char '/'
+  let backslash = char '\\'
+  let colon = char ':'
+  let semi = char ';'
+  let guillemet = char '"'
+  let quote = char '\''
+  let comma = char ','
+  let dot = char '.'
+  let question = char '?'
+  let lparen = char '('
+  let rparen = char ')'
+  let lbrace = char '{'
+  let rbrace = char '}'
+  let lbracket = char '['
+  let rbracket = char ']'
+  let langle = char '<'
+  let rangle = char '>'
+end
 
 module Dump = struct
   let list l : t =
     let sep = char ';' ^ nl in
     group (char '[' ^ nest 1 (fill sep l) ^ char ']')
+
+  let parens d = surround Char.lparen d Char.rparen
+  let braces d = surround Char.lbrace d Char.rbrace
+  let brackets d = surround Char.lbracket d Char.rbracket
+  let angles d = surround Char.langle d Char.rangle
+
+  let of_iter ?(sep = nil) g it =
+    let r = ref nil in
+    it (fun elt -> r := !r ^ sep ^ g elt);
+    !r
+
+  let of_array ?(sep = nil) g arr =
+    let r = ref nil in
+    for i = 0 to Array.length arr - 1 do
+      r := !r ^ sep ^ g arr.(i)
+    done;
+    !r
 end
 
 module Term_color = struct
diff --git a/src/pp/containers_pp.mli b/src/pp/containers_pp.mli
index 780f38a0..be634419 100644
--- a/src/pp/containers_pp.mli
+++ b/src/pp/containers_pp.mli
@@ -32,6 +32,8 @@
 
 (** {2 Core} *)
 
+type 'a iter = ('a -> unit) -> unit
+
 type t
 (** The type of documents *)
 
@@ -256,6 +258,26 @@ val sexp_l : t list -> t
 (** Printers that correspond closely to OCaml's syntax. *)
 module Dump : sig
   val list : t list -> t
+
+  val of_iter : ?sep:t -> ('a -> t) -> 'a iter -> t
+  (** @since NEXT_RELEASE *)
+
+  val of_array : ?sep:t -> ('a -> t) -> 'a array -> t
+  (** @since NEXT_RELEASE *)
+
+  val parens : t -> t
+  (** @since NEXT_RELEASE *)
+
+  val braces : t -> t
+  (** @since NEXT_RELEASE *)
+
+  val brackets : t -> t
+  (** Adds '[' ']' around the term
+      @since NEXT_RELEASE *)
+
+  val angles : t -> t
+  (** Adds '<' '>' around the term
+      @since NEXT_RELEASE *)
 end
 
 (** Simple colors in terminals *)
@@ -282,3 +304,43 @@ module Term_color : sig
   val color : color -> t -> t
   val style_l : style list -> t -> t
 end
+
+(** @since NEXT_RELEASE *)
+module Char : sig
+  val bang : t
+  val at : t
+  val hash : t
+  val dollar : t
+  val tilde : t
+  val backquote : t
+  val percent : t
+  val caret : t
+  val ampersand : t
+  val star : t
+  val minus : t
+  val underscore : t
+  val plus : t
+  val equal : t
+  val pipe : t
+  val slash : t
+  val backslash : t
+  val colon : t
+  val semi : t
+  val guillemet : t
+  val quote : t
+  val comma : t
+  val dot : t
+  val question : t
+  val lparen : t
+  val rparen : t
+  val lbrace : t
+  val rbrace : t
+  val lbracket : t
+  val rbracket : t
+  val langle : t
+  val rangle : t
+end
+
+val surround : ?width:int -> t -> t -> t -> t
+(** Generalization of {!bracket}
+    @since NEXT_RELEASE *)