Merge pull request #379 from shym/pp

Improve `Util.Pp` pretty-printers

CHANGES.md

@@ -2,6 +2,10 @@
 
 ## Next
 
+- #379: Extend the set of `Util.Pp` pretty-printers and teach them to
+  add break hints similar to `ppx_deriving.show`; teach `to_show` to
+  generate truncated strings when `$MCTUTILS_TRUNCATE` environment
+  variable is set
 - #368: Switch `STM_domain.agree_prop_par_asym` from using
   `Semaphore.Binary` to using an `int Atomic.t` which improves
   the error rate across platforms and backends

dune

@@ -1,5 +1,11 @@
 (env
- (debug-runtime (link_flags :standard -runtime-variant=d))
+ (debug-runtime
+  (link_flags :standard -runtime-variant=d)
+  (env-vars
+   (MCTUTILS_TRUNCATE 50)))
+ (_
+  (env-vars
+   (MCTUTILS_TRUNCATE 50)))
 )
 
 ;; make `dune build` target a recursive default target

lib/util.ml

@@ -80,28 +80,77 @@ module Pp = struct
 
   type 'a t = bool -> Format.formatter -> 'a -> unit
 
-  let to_show f x = asprintf "%a" (f false) x
+  type pp_thunk = Format.formatter -> unit
+
+  let truncate_message = "... (truncated)"
+
+  let truncate_length =
+    let truncate_env = "MCTUTILS_TRUNCATE" in
+    let ( let* ) = Option.bind in
+    let* l = Sys.getenv_opt truncate_env in
+    let* l = int_of_string_opt l in
+    (* it does not make sense to truncate at less than the length of
+       [truncate_message] *)
+    if l > 0 then Some (max l (String.length truncate_message - 1)) else None
+
+  let to_show f x =
+    match truncate_length with
+    | None ->
+        let buf = Buffer.create 512 in
+        let fmt = formatter_of_buffer buf in
+        pp_set_margin fmt max_int;
+        fprintf fmt "@[<h 0>%a@]@?" (f false) x;
+        let s = Buffer.contents buf in
+        Buffer.reset buf;
+        s
+    | Some trlen ->
+        (* if we overflow, we'll have the [truncate_message] at the end of the
+           buffer, filling it until [trlen + 1]: we'll use the fact that the
+           buffer contains more than [trlen] to indicate that it has already
+           overflown *)
+        let buf = Buffer.create (trlen + 1) in
+        let msglen = String.length truncate_message in
+        let out str ofs len =
+          let blen = Buffer.length buf in
+          (* if we didn't overflow yet... *)
+          if blen <= trlen then
+            if blen + len > trlen then (
+              let fits = trlen - blen - msglen + 1 in
+              if fits > 0 then Buffer.add_substring buf str ofs fits
+              else Buffer.truncate buf (trlen + 1 - msglen);
+              Buffer.add_string buf truncate_message)
+            else Buffer.add_substring buf str ofs len
+        in
+        let ppf = make_formatter out ignore in
+        pp_set_margin ppf max_int;
+        fprintf ppf "@[<h 0>%a@]@?" (f false) x;
+        let s = Buffer.contents buf in
+        Buffer.reset buf;
+        s
 
   let of_show f par fmt x =
-    fprintf fmt (if par then "(%s)" else "%s") (f x)
+    fprintf fmt (if par then "@[(%s)@]" else "@[%s@]") (f x)
 
   let cst0 name fmt = pp_print_string fmt name
 
   let cst1 (pp : 'a t) name par fmt x =
-    fprintf fmt (if par then "(%s %a)" else "%s %a") name (pp true) x
+    let o, c = if par then ("(", ")") else ("", "") in
+    fprintf fmt "%s@[<2>%s@ %a@]%s" o name (pp true) x c
 
   let cst2 (pp1 : 'a t) (pp2 : 'b t) name par fmt x y =
-    fprintf fmt (if par then "(%s (%a, %a))" else "%s (%a, %a)") name (pp1 false) x (pp2 false) y
+    let o, c = if par then ("(", ")") else ("", "") in
+    fprintf fmt "%s@[<2>%s (@,%a,@ %a)@]%s" o name (pp1 false) x (pp2 false) y c
 
   let cst3 (pp1 : 'a t) (pp2 : 'b t) (pp3 : 'c t) name par fmt x y z =
-    fprintf fmt
-      (if par then "(%s (%a, %a, %a))" else "%s (%a, %a, %a)")
-      name (pp1 false) x (pp2 false) y (pp3 false) z
+    let o, c = if par then ("(", ")") else ("", "") in
+    fprintf fmt "%s@[<2>%s (@,%a,@ %a,@ %a)@]%s" o name (pp1 false) x
+      (pp2 false) y (pp3 false) z c
 
   let pp_exn = of_show Printexc.to_string
   let pp_unit _ fmt () = pp_print_string fmt "()"
   let pp_bool _ fmt b = fprintf fmt "%B" b
   let pp_int par fmt i = fprintf fmt (if par && i < 0 then "(%d)" else "%d") i
+  let pp_int32 par fmt i = fprintf fmt (if par && i < 0l then "(%ldl)" else "%ldl") i
   let pp_int64 par fmt i = fprintf fmt (if par && i < 0L then "(%LdL)" else "%LdL") i
   let pp_float par fmt f = fprintf fmt (if par && f < 0.0 then "(%F)" else "%F") f
   let pp_char _ fmt c = fprintf fmt "%C" c
@@ -110,42 +159,144 @@ module Pp = struct
 
   let pp_option (pp_s : 'a t) par fmt o =
     match o with
-    | None -> pp_print_string fmt "None"
-    | Some s -> fprintf fmt (if par then "(Some %a)" else "Some %a") (pp_s true) s
+    | None -> cst0 "None" fmt
+    | Some s -> cst1 pp_s "Some" par fmt s
 
   let pp_result (pp_o : 'o t) (pp_e : 'e t) par fmt r =
     let open Result in
     match r with
-    | Ok o -> fprintf fmt (if par then "(Ok %a)" else "Ok %a") (pp_o true) o
-    | Error e -> fprintf fmt (if par then "(Error %a)" else "Error %a") (pp_e true) e
+    | Ok o -> cst1 pp_o "Ok" par fmt o
+    | Error e -> cst1 pp_e "Error" par fmt e
+
+  type pp_tuple_item = pp_thunk
+
+  let pp_tuple_item pp x fmt = pp false fmt x
+
+  let pp_tuple _ fmt items =
+    fprintf fmt "(@[";
+    pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") (fun fmt ppf -> ppf fmt) fmt items;
+    fprintf fmt "@])"
+
+  let pp_tuple2 pp1 pp2 p fmt (x1, x2) =
+    pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2 ]
+
+  let pp_tuple3 pp1 pp2 pp3 p fmt (x1, x2, x3) =
+    pp_tuple p fmt
+      [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3 ]
+
+  let pp_tuple4 pp1 pp2 pp3 pp4 p fmt (x1, x2, x3, x4) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+      ]
+
+  let pp_tuple5 pp1 pp2 pp3 pp4 pp5 p fmt (x1, x2, x3, x4, x5) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+      ]
+
+  let pp_tuple6 pp1 pp2 pp3 pp4 pp5 pp6 p fmt (x1, x2, x3, x4, x5, x6) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+        pp_tuple_item pp6 x6;
+      ]
+
+  let pp_tuple7 pp1 pp2 pp3 pp4 pp5 pp6 pp7 p fmt (x1, x2, x3, x4, x5, x6, x7) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+        pp_tuple_item pp6 x6;
+        pp_tuple_item pp7 x7;
+      ]
+
+  let pp_tuple8 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 p fmt
+      (x1, x2, x3, x4, x5, x6, x7, x8) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+        pp_tuple_item pp6 x6;
+        pp_tuple_item pp7 x7;
+        pp_tuple_item pp8 x8;
+      ]
+
+  let pp_tuple9 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 p fmt
+      (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+        pp_tuple_item pp6 x6;
+        pp_tuple_item pp7 x7;
+        pp_tuple_item pp8 x8;
+        pp_tuple_item pp9 x9;
+      ]
+
+  let pp_tuple10 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 pp10 p fmt
+      (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) =
+    pp_tuple p fmt
+      [
+        pp_tuple_item pp1 x1;
+        pp_tuple_item pp2 x2;
+        pp_tuple_item pp3 x3;
+        pp_tuple_item pp4 x4;
+        pp_tuple_item pp5 x5;
+        pp_tuple_item pp6 x6;
+        pp_tuple_item pp7 x7;
+        pp_tuple_item pp8 x8;
+        pp_tuple_item pp9 x9;
+        pp_tuple_item pp10 x10;
+      ]
 
-  let pp_pair (pp_f : 'a t) (pp_s : 'b t) _ fmt (x,y) =
-    fprintf fmt "(%a, %a)" (pp_f false) x (pp_s false) y
+  let pp_pair = pp_tuple2
 
   let pp_list (pp_e : 'a t) _ fmt l =
-    pp_print_string fmt "[";
+    fprintf fmt "@[<2>[";
     pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt l;
-    pp_print_string fmt "]"
+    fprintf fmt "@,]@]"
 
   let pp_seq (pp_e : 'a t) _ fmt s =
-    pp_print_string fmt "<";
+    fprintf fmt "@[<2><";
     pp_print_seq ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt s;
-    pp_print_string fmt ">"
+    fprintf fmt "@,>@]"
 
   let pp_array (pp_e : 'a t) _ fmt a =
-    pp_print_string fmt "[|";
+    fprintf fmt "@[<2>[|";
     pp_print_seq ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt (Array.to_seq a);
-    pp_print_string fmt "|]"
+    fprintf fmt "@,|]@]"
 
-  type pp_field = Format.formatter -> unit
+  type pp_field = pp_thunk
 
   let pp_field name (pp_c : 'a t) c fmt =
-    fprintf fmt "%s =@ %a" name (pp_c false) c
+    fprintf fmt "@[%s =@ %a@]" name (pp_c false) c
 
   let pp_record _ fmt fields =
-    pp_print_string fmt "{ ";
+    fprintf fmt "@[<2>{ ";
     pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (fun fmt ppf -> ppf fmt) fmt fields;
-    fprintf fmt "@ }"
+    fprintf fmt "@ }@]"
 end
 
 module Equal = struct

lib/util.mli

@@ -51,7 +51,10 @@ module Pp : sig
       if it produces a non-atomic expression. *)
 
   val to_show : 'a t -> 'a -> string
-  (** [to_show pp] converts a pretty-printer to a simple ['a -> string] function. *)
+  (** [to_show pp] converts a pretty-printer to a simple ['a -> string] function
+      that generate everything on one line. If the environment variable
+      [MCTUTILS_TRUNCATE] is set to a length, it will truncate the resulting
+      string if it exceeds that length. *)
 
   val of_show : ('a -> string) -> 'a t
   (** [of_show show] uses a simple ['a -> string] function as a pretty-printer.
@@ -90,6 +93,9 @@ module Pp : sig
   val pp_int : int t
   (** Pretty-printer for type [int] *)
 
+  val pp_int32 : int32 t
+  (** Pretty-printer for type [int32] *)
+
   val pp_int64 : int64 t
   (** Pretty-printer for type [int64] *)
 
@@ -114,10 +120,93 @@ module Pp : sig
       using [pp_ok] to pretty-print values of type ['o] and [pp_error] for
       values of type ['e]. *)
 
+  type pp_tuple_item
+  (** The abstract type for the pretty-printer of a tuple item *)
+
+  val pp_tuple_item : 'a t -> 'a -> pp_tuple_item
+  (** [pp_tuple_item pp v] builds a pretty-printer for a tuple item using [pp]
+      to pretty-print its value [v]. *)
+
+  val pp_tuple : pp_tuple_item list t
+  (** [pp_tuple] pretty-prints a tuple taken as a list of [pp_tuple_item]s. *)
+
   val pp_pair : 'a t -> 'b t -> ('a * 'b) t
   (** [pp_pair pp_a pp_b] pretty-prints a value of type ['a * 'b] using [pp_a]
       to pretty-print values of type ['a] and [pp_b] for values of type ['b]. *)
 
+  val pp_tuple2 : 'a t -> 'b t -> ('a * 'b) t
+  (** [pp_tuple2] pretty-prints pairs, synonym for [pp_pair]. *)
+
+  val pp_tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
+  (** [pp_tuple3] pretty-prints triples. *)
+
+  val pp_tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
+  (** [pp_tuple4] pretty-prints tuples of 4 elements. *)
+
+  val pp_tuple5 :
+    'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
+  (** [pp_tuple5] pretty-prints tuples of 5 elements. *)
+
+  val pp_tuple6 :
+    'a t ->
+    'b t ->
+    'c t ->
+    'd t ->
+    'e t ->
+    'f t ->
+    ('a * 'b * 'c * 'd * 'e * 'f) t
+  (** [pp_tuple6] pretty-prints tuples of 6 elements. *)
+
+  val pp_tuple7 :
+    'a t ->
+    'b t ->
+    'c t ->
+    'd t ->
+    'e t ->
+    'f t ->
+    'g t ->
+    ('a * 'b * 'c * 'd * 'e * 'f * 'g) t
+  (** [pp_tuple7] pretty-prints tuples of 7 elements. *)
+
+  val pp_tuple8 :
+    'a t ->
+    'b t ->
+    'c t ->
+    'd t ->
+    'e t ->
+    'f t ->
+    'g t ->
+    'h t ->
+    ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
+  (** [pp_tuple8] pretty-prints tuples of 8 elements. *)
+
+  val pp_tuple9 :
+    'a t ->
+    'b t ->
+    'c t ->
+    'd t ->
+    'e t ->
+    'f t ->
+    'g t ->
+    'h t ->
+    'i t ->
+    ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
+  (** [pp_tuple9] pretty-prints tuples of 9 elements. *)
+
+  val pp_tuple10 :
+    'a t ->
+    'b t ->
+    'c t ->
+    'd t ->
+    'e t ->
+    'f t ->
+    'g t ->
+    'h t ->
+    'i t ->
+    'j t ->
+    ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j) t
+  (** [pp_tuple10] pretty-prints tuples of 10 elements. *)
+
   val pp_list : 'a t -> 'a list t
   (** [pp_list pp] pretty-prints a list using [pp] to pretty-print its elements. *)
 
@@ -128,10 +217,10 @@ module Pp : sig
   (** [pp_array pp] pretty-prints an array using [pp] to pretty-print its elements. *)
 
   type pp_field
-  (** The abtract type for the pretty-printer of a record field *)
+  (** The abstract type for the pretty-printer of a record field *)
 
   val pp_field : string -> 'a t -> 'a -> pp_field
-  (** [pp_field name pp v] build a pretty-printer for a record field of given
+  (** [pp_field name pp v] builds a pretty-printer for a record field of given
       [name] using [pp] to pretty-print its content value [v]. *)
 
   val pp_record : pp_field list t