diff --git a/CHANGES.md b/CHANGES.md index 6cf64414..ef84607d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,7 +2,7 @@ ## Next release -- ... +- #486: Add `Util.Pp.pp_fun_` printer for generated `QCheck.fun_` functions ## 0.4 diff --git a/lib/util.ml b/lib/util.ml index 098d5432..33834963 100644 --- a/lib/util.ml +++ b/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 diff --git a/lib/util.mli b/lib/util.mli index 5dee0421..96902739 100644 --- a/lib/util.mli +++ b/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 diff --git a/src/array/stm_tests.ml b/src/array/stm_tests.ml index 2e012438..79e935c4 100644 --- a/src/array/stm_tests.ml +++ b/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 diff --git a/src/lazy/stm_tests.ml b/src/lazy/stm_tests.ml index 2c728134..8d86669f 100644 --- a/src/lazy/stm_tests.ml +++ b/src/lazy/stm_tests.ml @@ -37,12 +37,8 @@ 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 @@ -50,8 +46,8 @@ struct | 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 diff --git a/test/dune b/test/dune index 3658ae24..10855d37 100644 --- a/test/dune +++ b/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 "" diff --git a/test/util_pp.expected b/test/util_pp.expected index ba5c00a3..4493eaaa 100644 --- a/test/util_pp.expected +++ b/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} + diff --git a/test/util_pp.ml b/test/util_pp.ml index c52e4154..b970d5f7 100644 --- a/test/util_pp.ml +++ b/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 ()) diff --git a/test/util_pp_trunc150.expected b/test/util_pp_trunc150.expected index 502fe675..c0b74a12 100644 --- a/test/util_pp_trunc150.expected +++ b/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} + diff --git a/test/util_pp_trunc5.expected b/test/util_pp_trunc5.expected index 36140656..81f0a296 100644 --- a/test/util_pp_trunc5.expected +++ b/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) + diff --git a/test/util_pp_trunc79.expected b/test/util_pp_trunc79.expected index 2b10a364..178f44fe 100644 --- a/test/util_pp_trunc79.expected +++ b/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} +