Improve the Pp API (ocaml#2202)

- reduce the number of combinators to learn
- replace functions named after type names by more ppish functions

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

src/action_to_sh.ml

@@ -91,7 +91,7 @@ let simplify act =
   in
   block act
 
-let quote s = Pp.string (quote_for_shell s)
+let quote s = Pp.verbatim (quote_for_shell s)
 
 let rec pp = function
   | Run (prog, args) ->
@@ -101,14 +101,14 @@ let rec pp = function
          [Pp.space; quote arg]))
   | Chdir dir ->
     Pp.hovbox ~indent:2
-      [ Pp.string "cd"
+      [ Pp.verbatim "cd"
       ; Pp.space
       ; quote dir
       ]
   | Setenv (k, v) ->
-    Pp.concat [Pp.string k; Pp.string "="; quote v]
+    Pp.concat [Pp.verbatim k; Pp.verbatim "="; quote v]
   | Sh s ->
-    Pp.string s
+    Pp.verbatim s
   | Redirect (l, outputs, dest) ->
     let body =
       match l with
@@ -118,8 +118,8 @@ let rec pp = function
           [ Pp.hvbox ~indent:2
               [ Pp.char '{'
               ; Pp.space
-              ; Pp.hvbox [Pp.list l ~f:(fun x -> Pp.seq (pp x) (Pp.char ';'))
-                             ~sep:Pp.space]
+              ; Pp.hvbox [Pp.concat_map l ~sep:Pp.space
+                            ~f:(fun x -> Pp.seq (pp x) (Pp.char ';'))]
               ]
           ; Pp.space
           ; Pp.char '}'
@@ -128,7 +128,7 @@ let rec pp = function
     Pp.hovbox ~indent:2
       [ body
       ; Pp.space
-      ; Pp.string (match outputs with
+      ; Pp.verbatim (match outputs with
           | Stdout -> ">"
           | Stderr -> "2>"
           | Outputs -> "&>")
@@ -140,7 +140,7 @@ let rec pp = function
       ]
 
 let rec pp_seq = function
-  | [] -> Pp.string "true"
+  | [] -> Pp.verbatim "true"
   | [x] -> pp x
   | x :: l ->
     Pp.concat

src/stdune/dyn.ml

@@ -1,60 +1,60 @@
 include Dyn0
 
 let rec pp = function
-  | Unit -> Pp.string "()"
-  | Int i -> Pp.int i
-  | Bool b -> Pp.bool b
-  | String s -> Pp.string s
-  | Bytes b -> Pp.string (Bytes.to_string b)
+  | Unit -> Pp.verbatim "()"
+  | Int i -> Pp.verbatim (string_of_int i)
+  | Bool b -> Pp.verbatim (string_of_bool b)
+  | String s -> Pp.verbatim s
+  | Bytes b -> Pp.verbatim (Bytes.to_string b)
   | Char c -> Pp.char c
-  | Float f -> Pp.float f
-  | Sexp s -> Pp.sexp s
+  | Float f -> Pp.verbatim (string_of_float f)
+  | Sexp s -> pp_sexp s
   | Option None -> pp (Variant ("None", []))
   | Option (Some x) -> pp (Variant ("Some", [x]))
   | List x ->
     Pp.box
       [ Pp.char '['
-      ; Pp.list ~sep:(Pp.seq (Pp.char ';') Pp.space) x ~f:pp
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) x ~f:pp
       ; Pp.char ']'
       ]
   | Array a ->
     Pp.box
-      [ Pp.string "[|"
-      ; Pp.list ~sep:(Pp.seq (Pp.char ';') Pp.space) (Array.to_list a) ~f:pp
-      ; Pp.string "|]"
+      [ Pp.verbatim "[|"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) (Array.to_list a) ~f:pp
+      ; Pp.verbatim "|]"
       ]
   | Set xs ->
     Pp.box
-      [ Pp.string "set {"
-      ; Pp.list ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:pp
-      ; Pp.string "}"
+      [ Pp.verbatim "set {"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:pp
+      ; Pp.verbatim "}"
       ]
   | Map xs ->
     Pp.box
-      [ Pp.string "map {"
-      ; Pp.list ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:(fun (k, v) ->
+      [ Pp.verbatim "map {"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:(fun (k, v) ->
           Pp.box
             [ pp k
             ; Pp.space
-            ; Pp.string ":"
+            ; Pp.verbatim ":"
             ; Pp.space
             ; pp v
             ]
         )
-      ; Pp.string "}"
+      ; Pp.verbatim "}"
       ]
   | Tuple x ->
     Pp.box
       [ Pp.char '('
-      ; Pp.list ~sep:(Pp.seq (Pp.char ',') Pp.space) x ~f:pp
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ',') Pp.space) x ~f:pp
       ; Pp.char ')'
       ]
   | Record fields ->
     Pp.vbox ~indent:2
       [ Pp.char '{'
-      ; Pp.list ~sep:(Pp.char ';') fields ~f:(fun (f, v) ->
+      ; Pp.concat_map ~sep:(Pp.char ';') fields ~f:(fun (f, v) ->
           Pp.concat
-            [ Pp.string f
+            [ Pp.verbatim f
             ; Pp.space
             ; Pp.char '='
             ; Pp.space
@@ -63,12 +63,22 @@ let rec pp = function
         )
       ; Pp.char '}'
       ]
-  | Variant (v, []) -> Pp.string v
+  | Variant (v, []) -> Pp.verbatim v
   | Variant (v, xs) ->
     Pp.hvbox ~indent:2
-      [ Pp.string v
+      [ Pp.verbatim v
       ; Pp.space
-      ; Pp.list ~sep:(Pp.char ',') xs ~f:pp
+      ; Pp.concat_map ~sep:(Pp.char ',') xs ~f:pp
+      ]
+
+and pp_sexp = function
+  | Sexp.Atom s -> Pp.verbatim (Escape.quote_if_needed s)
+  | List [] -> Pp.verbatim "()"
+  | List l ->
+    Pp.box ~indent:1
+      [ Pp.char '('
+      ; Pp.hvbox [ Pp.concat_map l ~sep:Pp.space ~f:pp_sexp ]
+      ; Pp.char ')'
       ]
 
 let pp fmt t = Pp.pp fmt (pp t)

src/stdune/pp.ml

@@ -3,21 +3,15 @@ module String = Dune_caml.StringLabels
 type +'a t =
   | Nop
   | Seq of 'a t * 'a t
-  | Concat of 'a t list
+  | Concat of 'a t * 'a t list
   | Box of int * 'a t
   | Vbox of int * 'a t
   | Hbox of 'a t
   | Hvbox of int * 'a t
   | Hovbox of int * 'a t
-  | Bool of bool
-  | Int of int
-  | String of string
+  | Verbatim of string
   | Char of char
-  | Float of float
-  | Sexp of Sexp0.t
-  | List : 'b t * ('a -> 'b t) * 'a list -> 'b t
-  | Space
-  | Cut
+  | Break of int * int
   | Newline
   | Text of string
   | Tag of 'a * 'a t
@@ -83,7 +77,12 @@ module Renderer = struct
       match t with
       | Nop -> ()
       | Seq (a, b) -> pp th ppf a; pp th ppf b
-      | Concat l -> List.iter l ~f:(pp th ppf)
+      | Concat (_, []) -> ()
+      | Concat (sep, x :: l) ->
+        pp th ppf x;
+        List.iter l ~f:(fun x ->
+          pp th ppf sep;
+          pp th ppf x)
       | Box (indent, t) ->
         pp_open_box ppf indent;
         pp th ppf t;
@@ -104,17 +103,9 @@ module Renderer = struct
         pp_open_hovbox ppf indent;
         pp th ppf t;
         pp_close_box ppf ()
-      | Bool   x -> pp_print_bool ppf x
-      | Int    x -> pp_print_int ppf x
-      | String x -> pp_print_string ppf x
+      | Verbatim x -> pp_print_string ppf x
       | Char   x -> pp_print_char ppf x
-      | Float  x -> pp_print_float ppf x
-      | Sexp x -> Sexp1.pp ppf x
-      | List (sep, f, l) ->
-        pp_print_list (fun ppf x -> pp th ppf (f x)) ppf l
-          ~pp_sep:(fun ppf () -> pp th ppf sep)
-      | Space -> pp_print_space ppf ()
-      | Cut -> pp_print_cut ppf ()
+      | Break (nspaces, shift) -> pp_print_break ppf nspaces shift
       | Newline -> pp_force_newline ppf ()
       | Text s -> pp_print_text ppf s
       | Tag (tag, t) ->
@@ -167,25 +158,30 @@ let pp ppf t = Render.pp () ppf t
 
 let nop = Nop
 let seq a b = Seq (a, b)
-let concat l = Concat l
-let box ?(indent=0) l = Box (indent, Concat l)
-let vbox ?(indent=0) l = Vbox (indent, Concat l)
-let hbox l = Hbox (Concat l)
-let hvbox ?(indent=0) l = Hvbox (indent, Concat l)
-let hovbox ?(indent=0) l = Hovbox (indent, Concat l)
-
-let bool b = Bool b
-let int x = Int x
-let string x = String x
+let concat ?(sep=Nop) = function
+  | [] -> Nop
+  | [x] -> x
+  | l -> Concat (sep, l)
+let concat_map ?(sep=Nop) l ~f =
+  match l with
+  | [] -> Nop
+  | [x] -> f x
+  | l -> Concat (sep, List.map l ~f)
+let box ?(indent=0) l = Box (indent, concat l)
+let vbox ?(indent=0) l = Vbox (indent, concat l)
+let hbox l = Hbox (concat l)
+let hvbox ?(indent=0) l = Hvbox (indent, concat l)
+let hovbox ?(indent=0) l = Hovbox (indent, concat l)
+
+let verbatim x = Verbatim x
 let char x = Char x
-let float x = Float x
-let sexp s = Sexp s
-let list ?(sep=Cut) l ~f = List (sep, f, l)
 
-let space = Space
-let cut = Cut
+let break ~nspaces ~shift = Break (nspaces, shift)
+let space = Break (1, 0)
+let cut = Break (0, 0)
 let newline = Newline
 
 let text s = Text s
+let textf fmt = Printf.ksprintf text fmt
 
 let tag t ~tag = Tag (tag, t)

src/stdune/pp.mli

@@ -5,6 +5,85 @@
     styles. *)
 type +'tag t
 
+(** {1 Basic combinators} *)
+
+(** A pretty printer that prints nothing *)
+val nop : _ t
+
+(** [seq x y] prints [x] and then [y] *)
+val seq : 'a t -> 'a t -> 'a t
+
+(** [concat ?sep l] prints elements in [l] separated by [sep]. [sep]
+    defaults to [nop]. *)
+val concat : ?sep:'a t -> 'a t list -> 'a t
+
+(** Convenience function for [List.map] followed by [concat] *)
+val concat_map : ?sep:'a t -> 'b list -> f:('b -> 'a t) -> 'a t
+
+(** An indivisible block of text *)
+val verbatim : string -> _ t
+
+(** A single character *)
+val char : char -> _ t
+
+(** Print a bunch of text. The line may be broken at any spaces in the
+    text. *)
+val text : string -> _ t
+
+(** Same as [text] but take a format string as argument. *)
+val textf : ('a, unit, string, _ t) format4 -> 'a
+
+(** [tag t ~tag] Tag the material printed by [t] with [tag] *)
+val tag : 'a t -> tag:'a -> 'a t
+
+(** {1 Break hints} *)
+
+(** Either a newline or a space, depending on whether the line is
+    broken at this point. *)
+val space : _ t
+
+(** Either a newline or nothing, depending on whether the line is
+    broken at this point. *)
+val cut : _ t
+
+(** Either a newline or [nspaces] spaces. If it is a newline, [shift]
+    is added to the indentation level. *)
+val break : nspaces:int -> shift:int -> _ t
+
+(** Force a newline to be printed *)
+val newline : _ t
+
+(** {1 Boxes} *)
+
+(** Boxes are the basic components to control the layout of the text.
+    Break hints such as [space] and [cut] may cause the line to be
+    broken, depending on the splitting rules.  Whenever a line is
+    split, the rest of the material printed in the box is indented with
+    [indent].
+
+    All functions take a list as argument for convenience.  Elements
+    are printed one by one. *)
+
+(** Try to put as much as possible on each line.  Additionally, a
+    break hint always break the line if the breaking would reduce the
+    indentation level ([break] with negative [shift] value). *)
+val box : ?indent:int -> 'a t list -> 'a t
+
+(** Always break the line when encountering a break hint. *)
+val vbox : ?indent:int -> 'a t list -> 'a t
+
+(** Print everything on one line, no matter what *)
+val hbox : 'a t list -> 'a t
+
+(** If possible, print everything on one line. Otherwise, behave as a
+    [vbox] *)
+val hvbox : ?indent:int -> 'a t list -> 'a t
+
+(** Try to put as much as possible on each line. *)
+val hovbox : ?indent:int -> 'a t list -> 'a t
+
+(** {1 Rendering} *)
+
 module type Tag = sig
   type t
 
@@ -44,29 +123,5 @@ module Render : Renderer.S
     with type Tag.t         = unit
     with type Tag.Handler.t = unit
 
+(** Render to a formatter *)
 val pp : Format.formatter -> unit t -> unit
-
-val nop : 'a t
-val seq : 'a t -> 'a t -> 'a t
-val concat : 'a t list -> 'a t
-val box : ?indent:int -> 'a t list -> 'a t
-val vbox : ?indent:int -> 'a t list -> 'a t
-val hbox : 'a t list -> 'a t
-val hvbox : ?indent:int -> 'a t list -> 'a t
-val hovbox : ?indent:int -> 'a t list -> 'a t
-
-val bool   : bool   -> _ t
-val int    : int    -> _ t
-val string : string -> _ t
-val char   : char   -> _ t
-val float  : float  -> _ t
-val sexp  : Sexp0.t  -> _ t
-val list   : ?sep:'b t -> 'a list -> f:('a -> 'b t) -> 'b t
-
-val space   : _ t
-val cut     : _ t
-val newline : _ t
-
-val text : string -> _ t
-
-val tag : 'a t -> tag:'a -> 'a t