Merge pull request #486 from ocaml-multicore/util-pp-add-fun

Add Util.Pp.fun_ printer for generated QCheck.fun_ functions

Author: jmid

CHANGES.md

@@ -2,7 +2,7 @@
 
 ## Next release
 
-- ...
+- #486: Add `Util.Pp.pp_fun_` printer for generated `QCheck.fun_` functions
 
 ## 0.4
 

lib/util.ml

@@ -297,6 +297,8 @@ module Pp = struct
     fprintf fmt "@[<2>{ ";
     pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (fun fmt ppf -> ppf fmt) fmt fields;
     fprintf fmt "@ }@]"
+
+  let pp_fun_ par fmt f = fprintf fmt (if par then "(%s)" else "%s") (QCheck.Fn.print f)
 end
 
 module Equal = struct

lib/util.mli

@@ -226,6 +226,9 @@ module Pp : sig
   val pp_record : pp_field list t
   (** [pp_record flds] pretty-prints a record using the list of pretty-printers
       of its fields. *)
+
+  val pp_fun_ : _ QCheck.fun_ t
+  (** Pretty-printer for QCheck's function type [fun_] *)
 end
 
 module Equal : sig

src/array/stm_tests.ml

@@ -5,11 +5,6 @@ open STM
 
 module AConf =
 struct
-  type char_bool_fun = (char -> bool) fun_
-
-  let pp_char_bool_fun par fmt f =
-    Format.fprintf fmt (if par then "(%s)" else "%s") (Fn.print f)
-
   type cmd =
     | Length
     | Get of int
@@ -18,10 +13,10 @@ struct
     | Copy
     | Fill of int * int * char
     | To_list
-    | For_all of char_bool_fun
-    | Exists of char_bool_fun
+    | For_all of (char -> bool) fun_
+    | Exists of (char -> bool) fun_
     | Mem of char
-    | Find_opt of char_bool_fun
+    | Find_opt of (char -> bool) fun_
   (*| Find_index of char_bool_fun since 5.1*)
     | Sort
     | Stable_sort
@@ -38,10 +33,10 @@ struct
     | Copy -> cst0 "Copy" fmt
     | Fill (x, y, z) -> cst3 pp_int pp_int pp_char "Fill" par fmt x y z
     | To_list -> cst0 "To_list" fmt
-    | For_all f -> cst1 pp_char_bool_fun "For_all" par fmt f
-    | Exists f -> cst1 pp_char_bool_fun "Exists" par fmt f
+    | For_all f -> cst1 pp_fun_ "For_all" par fmt f
+    | Exists f -> cst1 pp_fun_ "Exists" par fmt f
     | Mem x -> cst1 pp_char "Mem" par fmt x
-    | Find_opt f -> cst1 pp_char_bool_fun "Find_opt" par fmt f
+    | Find_opt f -> cst1 pp_fun_ "Find_opt" par fmt f
   (*| Find_index f -> cst1 pp_char_bool_fun "Find_index" par fmt f*)
     | Sort -> cst0 "Sort" fmt
     | Stable_sort -> cst0 "Stable_sort" fmt

src/lazy/stm_tests.ml

@@ -37,21 +37,17 @@ struct
     | Force
     | Force_val
     | Is_val
-    | Map of int_fun
-    | Map_val of int_fun
-  and int_fun = (int -> int) fun_
-
-  let pp_int_fun par fmt f =
-    Format.fprintf fmt (if par then "(%s)" else "%s") (Fn.print f)
+    | Map of (int -> int) fun_
+    | Map_val of (int -> int) fun_
 
   let pp_cmd par fmt x =
     let open Util.Pp in
     match x with
     | Force -> cst0 "Force" fmt
     | Force_val -> cst0 "Force_val" fmt
     | Is_val -> cst0 "Is_val" fmt
-    | Map x -> cst1 pp_int_fun "Map" par fmt x
-    | Map_val x -> cst1 pp_int_fun "Map_val" par fmt x
+    | Map x -> cst1 pp_fun_ "Map" par fmt x
+    | Map_val x -> cst1 pp_fun_ "Map_val" par fmt x
 
   let show_cmd = Util.Pp.to_show pp_cmd
 

test/dune

@@ -10,7 +10,7 @@
  (name util_pp)
  (modules util_pp)
  (package qcheck-multicoretests-util)
- (libraries qcheck-multicoretests-util)
+ (libraries qcheck-core qcheck-multicoretests-util)
  (action
   (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0"
    (setenv MCTUTILS_TRUNCATE ""

test/util_pp.expected

@@ -73,3 +73,6 @@ Test of pp_array pp_int (long):
 Test of pp_record:
 { key = 123; value = "content" }
 
+Test of pp_fun_:
+{(Some (-123456), a, xyz) -> true; (None, b, ) -> true; _ -> true}
+

test/util_pp.ml

@@ -11,6 +11,15 @@ let seq_interval x y () =
   in
   aux x
 
+let fun_val () =
+  let open QCheck in
+  let bool = set_gen (Gen.return true) bool in (* fix co-domain/range across RNGs *)
+  let gen = fun3 Observable.(option int) Observable.char Observable.string bool in
+  let fun_ = Gen.generate1 gen.gen in
+  let _ = Fn.apply fun_ (Some (-123456)) 'a' "xyz" in
+  let _ = Fn.apply fun_ None 'b' "" in
+  fun_
+
 let _ =
   pr "pp_bool" pp_bool true;
   pr "pp_int (positive)" pp_int 12345;
@@ -41,4 +50,5 @@ let _ =
   pr "pp_array pp_int" (pp_array pp_int) [| 1; 2; 3; -1; -2; -3 |];
   pr "pp_array pp_int (long)" (pp_array pp_int) (Array.make 100 0);
   pr "pp_record" pp_record
-    [ pp_field "key" pp_int 123; pp_field "value" pp_string "content" ]
+    [ pp_field "key" pp_int 123; pp_field "value" pp_string "content" ];
+  pr "pp_fun_" pp_fun_ (fun_val ())

test/util_pp_trunc150.expected

@@ -73,3 +73,6 @@ Test of pp_array pp_int (long):
 Test of pp_record:
 { key = 123; value = "content" }
 
+Test of pp_fun_:
+{(Some (-123456), a, xyz) -> true; (None, b, ) -> true; _ -> true}
+

test/util_pp_trunc5.expected

@@ -73,3 +73,6 @@ Test of pp_array pp_int (long):
 Test of pp_record:
 ... (truncated)
 
+Test of pp_fun_:
+... (truncated)
+

test/util_pp_trunc79.expected

@@ -73,3 +73,6 @@ Test of pp_array pp_int (long):
 Test of pp_record:
 { key = 123; value = "content" }
 
+Test of pp_fun_:
+{(Some (-123456), a, xyz) -> true; (None, b, ) -> true; _ -> true}
+