From 1ad3aa1e28c5cf0c3bc0c483483824cb2df4ed2d Mon Sep 17 00:00:00 2001 From: Mathieu Barbin Date: Fri, 19 Jan 2024 21:06:16 +0100 Subject: [PATCH] generate most of the bindings --- dune-project | 9 ++++ pbrt_quickcheck.opam | 32 +++++++++++++ src/compilerlib/dune | 51 ++++++++++++++++----- src/compilerlib/pb_codegen_quickcheck.ml | 42 +++++++++++++++++ src/compilerlib/pb_codegen_quickcheck.mli | 5 ++ src/ocaml-protoc/ocaml_protoc_cmdline.ml | 8 ++++ src/ocaml-protoc/ocaml_protoc_generation.ml | 4 ++ src/runtime-qcheck/dune | 7 +++ src/runtime-qcheck/pbrt_quickcheck.ml | 13 ++++++ src/tests/roundtrip/dune | 3 +- src/tests/roundtrip/empty.ml | 7 +-- src/tests/roundtrip/error_.ml | 7 +-- src/tests/roundtrip/messages.ml.expected | 44 ++++++++++++++++++ src/tests/roundtrip/messages.mli.expected | 15 ++++++ src/tests/roundtrip/person.ml | 7 +-- src/tests/roundtrip/roundtrip.ml | 25 ++++------ src/tests/roundtrip/roundtrip.mli | 9 +--- src/tests/roundtrip/unit_or_error.ml | 7 +-- 18 files changed, 237 insertions(+), 58 deletions(-) create mode 100644 pbrt_quickcheck.opam create mode 100644 src/compilerlib/pb_codegen_quickcheck.ml create mode 100644 src/compilerlib/pb_codegen_quickcheck.mli create mode 100644 src/runtime-qcheck/dune create mode 100644 src/runtime-qcheck/pbrt_quickcheck.ml diff --git a/dune-project b/dune-project index 7023c3a3..a3467355 100644 --- a/dune-project +++ b/dune-project @@ -47,6 +47,15 @@ (pbrt_yojson (= :version))) (tags (protobuf encode decode services rpc))) +(package + (name pbrt_quickcheck) + (synopsis "Runtime library for ocaml-protoc to support tests based on quickcheck") + (depends + (ocaml (>= 4.08)) + (pbrt (= :version)) + (pbrt_yojson (= :version))) + (tags (protobuf encode decode quickcheck rpc))) + (package (name ocaml-protoc-tests) (synopsis "Tests for ocaml-protoc and pbrt* packages") diff --git a/pbrt_quickcheck.opam b/pbrt_quickcheck.opam new file mode 100644 index 00000000..17e15ad8 --- /dev/null +++ b/pbrt_quickcheck.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "3.0.1" +synopsis: + "Runtime library for ocaml-protoc to support tests based on quickcheck" +maintainer: ["Maxime Ransan " "Simon Cruanes"] +authors: ["Maxime Ransan " "Simon Cruanes"] +license: "MIT" +tags: ["protobuf" "encode" "decode" "quickcheck" "rpc"] +homepage: "https://github.com/mransan/ocaml-protoc" +bug-reports: "https://github.com/mransan/ocaml-protoc/issues" +depends: [ + "dune" {>= "2.0"} + "ocaml" {>= "4.08"} + "pbrt" {= version} + "pbrt_yojson" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/mransan/ocaml-protoc.git" diff --git a/src/compilerlib/dune b/src/compilerlib/dune index 7bab48c5..739d8873 100644 --- a/src/compilerlib/dune +++ b/src/compilerlib/dune @@ -6,16 +6,45 @@ (name ocaml_protoc_compiler_lib) (public_name ocaml-protoc.compiler-lib) (synopsis - "Compiler library for ocaml-protoc, to turn .proto files into OCaml code") + "Compiler library for ocaml-protoc, to turn .proto files into OCaml code") (wrapped true) - (modules pb_codegen_all pb_codegen_backend pb_codegen_decode_binary - pb_codegen_decode_bs pb_codegen_decode_yojson pb_codegen_default - pb_codegen_make pb_codegen_encode_binary pb_codegen_encode_bs - pb_codegen_encode_yojson pb_codegen_formatting pb_codegen_ocaml_type_dump - pb_codegen_ocaml_type pb_codegen_pp pb_codegen_plugin pb_codegen_types - pb_codegen_services pb_codegen_util pb_exception pb_field_type pb_location - pb_logger pb_option pb_parsing pb_parsing_lexer pb_parsing_parser - pb_parsing_parse_tree pb_parsing_util pb_typing_graph pb_typing - pb_typing_recursion pb_typing_resolution pb_typing_type_tree - pb_typing_util pb_typing_validation pb_util pb_format_util) + (modules + pb_codegen_all + pb_codegen_backend + pb_codegen_decode_binary + pb_codegen_decode_bs + pb_codegen_decode_yojson + pb_codegen_default + pb_codegen_make + pb_codegen_encode_binary + pb_codegen_encode_bs + pb_codegen_encode_yojson + pb_codegen_formatting + pb_codegen_ocaml_type_dump + pb_codegen_ocaml_type + pb_codegen_pp + pb_codegen_quickcheck + pb_codegen_plugin + pb_codegen_types + pb_codegen_services + pb_codegen_util + pb_exception + pb_field_type + pb_location + pb_logger + pb_option + pb_parsing + pb_parsing_lexer + pb_parsing_parser + pb_parsing_parse_tree + pb_parsing_util + pb_typing_graph + pb_typing + pb_typing_recursion + pb_typing_resolution + pb_typing_type_tree + pb_typing_util + pb_typing_validation + pb_util + pb_format_util) (libraries stdlib-shims)) diff --git a/src/compilerlib/pb_codegen_quickcheck.ml b/src/compilerlib/pb_codegen_quickcheck.ml new file mode 100644 index 00000000..e713321e --- /dev/null +++ b/src/compilerlib/pb_codegen_quickcheck.ml @@ -0,0 +1,42 @@ +module Ot = Pb_codegen_ocaml_type +module F = Pb_codegen_formatting + +let type_name t = + match t with + | { Ot.spec = Ot.Record { Ot.r_name; _ }; _ } -> r_name + | { Ot.spec = Ot.Variant v; _ } -> v.Ot.v_name + | { Ot.spec = Ot.Const_variant { Ot.cv_name; _ }; _ } -> cv_name + | { Ot.spec = Ot.Unit { Ot.er_name; _ }; _ } -> er_name + +let gen_sig ?and_:_ t sc = + let type_name = type_name t in + F.linep sc "val quickcheck_%s : %s Pbrt_quickcheck.Type_class.t" type_name + type_name; + F.linep sc + "(** [quickcheck_%s] contains helpers to test the type %s with quickcheck \ + *)" + type_name type_name; + true + +let gen_struct ?and_:_ t sc = + let type_name = type_name t in + F.linep sc "let quickcheck_%s =" type_name; + F.linep sc " { Pbrt_quickcheck.Type_class."; + let field f = F.linep sc " %s = %s_%s;" f f type_name in + List.iter field + [ "pp"; "equal"; "encode_pb"; "decode_pb"; "encode_json"; "decode_json" ]; + F.linep sc " }"; + + true + +let ocamldoc_title = "QuickCheck" +let requires_mutable_records = false + +let plugin : Pb_codegen_plugin.t = + let module P = struct + let gen_sig = gen_sig + let gen_struct = gen_struct + let ocamldoc_title = ocamldoc_title + let requires_mutable_records = requires_mutable_records + end in + (module P) diff --git a/src/compilerlib/pb_codegen_quickcheck.mli b/src/compilerlib/pb_codegen_quickcheck.mli new file mode 100644 index 00000000..de12054c --- /dev/null +++ b/src/compilerlib/pb_codegen_quickcheck.mli @@ -0,0 +1,5 @@ +(** Plugin that generates values for QuickCheck tests. *) + +include Pb_codegen_plugin.S + +val plugin : Pb_codegen_plugin.t diff --git a/src/ocaml-protoc/ocaml_protoc_cmdline.ml b/src/ocaml-protoc/ocaml_protoc_cmdline.ml index 1f0a5e2a..d117c768 100644 --- a/src/ocaml-protoc/ocaml_protoc_cmdline.ml +++ b/src/ocaml-protoc/ocaml_protoc_cmdline.ml @@ -112,6 +112,7 @@ module Cmdline = struct pp: bool ref; (** whether pretty printing is enabled *) dump_type_repr: bool ref; (** whether comments with debug ocaml type representation are added *) + quickcheck: bool ref; (** whether quickcheck code generation is enabled *) services: bool ref; (** whether services code generation is enabled *) make: bool ref; (** whether to generate "make" functions *) mutable cmd_line_file_options: File_options.t; @@ -132,6 +133,7 @@ module Cmdline = struct bs = ref false; pp = ref false; dump_type_repr = ref false; + quickcheck = ref false; services = ref false; make = ref false; cmd_line_file_options = File_options.make (); @@ -148,6 +150,7 @@ module Cmdline = struct Arg.Set t.dump_type_repr, " generate comments with internal representation on generated OCaml \ types (useful for debugging ocaml-protoc itself)" ); + "--quickcheck", Arg.Set t.quickcheck, " generate quickcheck helpers"; ( "--services", Arg.Set t.services, " generate code for services (requires json+binary)" ); @@ -177,6 +180,11 @@ module Cmdline = struct t.pp := true ); + if !(t.quickcheck) then ( + t.binary := true; + t.yojson := true + ); + if !(t.services) then ( t.binary := true; t.yojson := true diff --git a/src/ocaml-protoc/ocaml_protoc_generation.ml b/src/ocaml-protoc/ocaml_protoc_generation.ml index a1cc999b..c10340b7 100644 --- a/src/ocaml-protoc/ocaml_protoc_generation.ml +++ b/src/ocaml-protoc/ocaml_protoc_generation.ml @@ -76,6 +76,10 @@ let generate_code ocaml_types ~proto_file_options cmdline : unit = [ Pb_codegen_encode_bs.plugin; Pb_codegen_decode_bs.plugin ] else []); + (if !(cmdline.Cmdline.quickcheck) then + [ Pb_codegen_quickcheck.plugin ] + else + []); ] in diff --git a/src/runtime-qcheck/dune b/src/runtime-qcheck/dune new file mode 100644 index 00000000..373a73a9 --- /dev/null +++ b/src/runtime-qcheck/dune @@ -0,0 +1,7 @@ +(library + (public_name pbrt_quickcheck) + (wrapped false) + (libraries + pbrt + (re_export qcheck) + yojson)) diff --git a/src/runtime-qcheck/pbrt_quickcheck.ml b/src/runtime-qcheck/pbrt_quickcheck.ml new file mode 100644 index 00000000..f0e0baed --- /dev/null +++ b/src/runtime-qcheck/pbrt_quickcheck.ml @@ -0,0 +1,13 @@ +(** Runtime for QuickCheck based tests. *) + +(** A type class generated for each type *) +module Type_class = struct + type 'a t = { + pp: Format.formatter -> 'a -> unit; + equal: 'a -> 'a -> bool; + encode_pb: 'a -> Pbrt.Encoder.t -> unit; + decode_pb: Pbrt.Decoder.t -> 'a; + encode_json: 'a -> Yojson.Basic.t; + decode_json: Yojson.Basic.t -> 'a; + } +end diff --git a/src/tests/roundtrip/dune b/src/tests/roundtrip/dune index f507f039..77274eab 100644 --- a/src/tests/roundtrip/dune +++ b/src/tests/roundtrip/dune @@ -3,7 +3,7 @@ (public_name ocaml-protoc-tests.roundtrip-tests) (inline_tests) (flags :standard -w -66) - (libraries pbrt pbrt_yojson qcheck qcheck-core yojson) + (libraries pbrt pbrt_yojson pbrt_quickcheck qcheck qcheck-core yojson) (preprocess (pps ppx_deriving_qcheck ppx_expect ppx_deriving.show ppx_deriving.eq))) @@ -17,6 +17,7 @@ "deriving show { with_path = false }, eq" --binary --yojson + --quickcheck --ml_out ./ %{deps}))) diff --git a/src/tests/roundtrip/empty.ml b/src/tests/roundtrip/empty.ml index dc4d3c29..2ebae985 100644 --- a/src/tests/roundtrip/empty.ml +++ b/src/tests/roundtrip/empty.ml @@ -1,12 +1,7 @@ module T = struct type t = unit [@@deriving qcheck2] - let pp = Messages.pp_empty - let equal = Messages.equal_empty - let encode_pb = Messages.encode_pb_empty - let decode_pb = Messages.decode_pb_empty - let encode_json = Messages.encode_json_empty - let decode_json = Messages.decode_json_empty + let quickcheck = Messages.quickcheck_empty end include T diff --git a/src/tests/roundtrip/error_.ml b/src/tests/roundtrip/error_.ml index fcd8db34..830a74a2 100644 --- a/src/tests/roundtrip/error_.ml +++ b/src/tests/roundtrip/error_.ml @@ -1,12 +1,7 @@ module T = struct type t = Messages.error = { error: string } [@@deriving qcheck2] - let pp = Messages.pp_error - let equal = Messages.equal_error - let encode_pb = Messages.encode_pb_error - let decode_pb = Messages.decode_pb_error - let encode_json = Messages.encode_json_error - let decode_json = Messages.decode_json_error + let quickcheck = Messages.quickcheck_error end include T diff --git a/src/tests/roundtrip/messages.ml.expected b/src/tests/roundtrip/messages.ml.expected index f421c637..d7aafbc0 100644 --- a/src/tests/roundtrip/messages.ml.expected +++ b/src/tests/roundtrip/messages.ml.expected @@ -277,3 +277,47 @@ let rec decode_json_unit_or_error json = | _ :: tl -> loop tl in loop assoc + +[@@@ocaml.warning "-27-30-39"] + +(** {2 QuickCheck} *) + +let quickcheck_person = + { Pbrt_quickcheck.Type_class. + pp = pp_person; + equal = equal_person; + encode_pb = encode_pb_person; + decode_pb = decode_pb_person; + encode_json = encode_json_person; + decode_json = decode_json_person; + } + +let quickcheck_empty = + { Pbrt_quickcheck.Type_class. + pp = pp_empty; + equal = equal_empty; + encode_pb = encode_pb_empty; + decode_pb = decode_pb_empty; + encode_json = encode_json_empty; + decode_json = decode_json_empty; + } + +let quickcheck_error = + { Pbrt_quickcheck.Type_class. + pp = pp_error; + equal = equal_error; + encode_pb = encode_pb_error; + decode_pb = decode_pb_error; + encode_json = encode_json_error; + decode_json = decode_json_error; + } + +let quickcheck_unit_or_error = + { Pbrt_quickcheck.Type_class. + pp = pp_unit_or_error; + equal = equal_unit_or_error; + encode_pb = encode_pb_unit_or_error; + decode_pb = decode_pb_unit_or_error; + encode_json = encode_json_unit_or_error; + decode_json = decode_json_unit_or_error; + } diff --git a/src/tests/roundtrip/messages.mli.expected b/src/tests/roundtrip/messages.mli.expected index 2c1b9ac7..64ba3c19 100644 --- a/src/tests/roundtrip/messages.mli.expected +++ b/src/tests/roundtrip/messages.mli.expected @@ -111,3 +111,18 @@ val decode_json_error : Yojson.Basic.t -> error val decode_json_unit_or_error : Yojson.Basic.t -> unit_or_error (** [decode_json_unit_or_error decoder] decodes a [unit_or_error] value from [decoder] *) + + +(** {2 QuickCheck} *) + +val quickcheck_person : person Pbrt_quickcheck.Type_class.t +(** [quickcheck_person] contains helpers to test the type person with quickcheck *) + +val quickcheck_empty : empty Pbrt_quickcheck.Type_class.t +(** [quickcheck_empty] contains helpers to test the type empty with quickcheck *) + +val quickcheck_error : error Pbrt_quickcheck.Type_class.t +(** [quickcheck_error] contains helpers to test the type error with quickcheck *) + +val quickcheck_unit_or_error : unit_or_error Pbrt_quickcheck.Type_class.t +(** [quickcheck_unit_or_error] contains helpers to test the type unit_or_error with quickcheck *) diff --git a/src/tests/roundtrip/person.ml b/src/tests/roundtrip/person.ml index d26000ad..25a6494b 100644 --- a/src/tests/roundtrip/person.ml +++ b/src/tests/roundtrip/person.ml @@ -7,12 +7,7 @@ module T = struct } [@@deriving qcheck2] - let pp = Messages.pp_person - let equal = Messages.equal_person - let encode_pb = Messages.encode_pb_person - let decode_pb = Messages.decode_pb_person - let encode_json = Messages.encode_json_person - let decode_json = Messages.decode_json_person + let quickcheck = Messages.quickcheck_person end include T diff --git a/src/tests/roundtrip/roundtrip.ml b/src/tests/roundtrip/roundtrip.ml index 2d9c9d03..0906501b 100644 --- a/src/tests/roundtrip/roundtrip.ml +++ b/src/tests/roundtrip/roundtrip.ml @@ -1,13 +1,8 @@ module type S = sig type t - val pp : Format.formatter -> t -> unit - val equal : t -> t -> bool + val quickcheck : t Pbrt_quickcheck.Type_class.t val gen : t QCheck2.Gen.t - val encode_pb : t -> Pbrt.Encoder.t -> unit - val decode_pb : Pbrt.Decoder.t -> t - val encode_json : t -> Yojson.Basic.t - val decode_json : Yojson.Basic.t -> t end module Test_failure = struct @@ -28,16 +23,16 @@ let () = | _ -> None) let show (type a) (module M : S with type t = a) (t : a) = - Format.asprintf "%a" M.pp t + Format.asprintf "%a" M.quickcheck.pp t let roundtrip_property_exn (type a) (module M : S with type t = a) ~encoder (t : a) = Pbrt.Encoder.clear encoder; - M.encode_pb t encoder; + M.quickcheck.encode_pb t encoder; let encoded = Pbrt.Encoder.to_string encoder in let decoder = Pbrt.Decoder.of_string encoded in - let decoded = M.decode_pb decoder in - if not (M.equal t decoded) then + let decoded = M.quickcheck.decode_pb decoder in + if not (M.quickcheck.equal t decoded) then raise (Test_failure { @@ -47,9 +42,9 @@ let roundtrip_property_exn (type a) (module M : S with type t = a) ~encoder encoded; }); - let encoded = M.encode_json t |> Yojson.Basic.to_string in - let decoded = M.decode_json (Yojson.Basic.from_string encoded) in - if not (M.equal t decoded) then + let encoded = M.quickcheck.encode_json t |> Yojson.Basic.to_string in + let decoded = M.quickcheck.decode_json (Yojson.Basic.from_string encoded) in + if not (M.quickcheck.equal t decoded) then raise (Test_failure { @@ -71,8 +66,8 @@ let run (type a) ?(examples = []) (module M : S with type t = a) = match QCheck2.TestResult.get_state test_result with | Success -> () | Error { instance; exn; backtrace = _ } -> - Format.printf "QCheck2.Test.check_cell failed\ninput: %a\nerror: %s@." M.pp - instance.instance (Printexc.to_string exn) + Format.printf "QCheck2.Test.check_cell failed\ninput: %a\nerror: %s@." + M.quickcheck.pp instance.instance (Printexc.to_string exn) | Failed { instances = _ } | Failed_other { msg = _ } -> (* These cases are never triggered because we systematically raise with added context if the property doesn't hold. *) diff --git a/src/tests/roundtrip/roundtrip.mli b/src/tests/roundtrip/roundtrip.mli index b922639b..0d148992 100644 --- a/src/tests/roundtrip/roundtrip.mli +++ b/src/tests/roundtrip/roundtrip.mli @@ -1,13 +1,8 @@ module type S = sig type t - val pp : Format.formatter -> t -> unit - val equal : t -> t -> bool + val quickcheck : t Pbrt_quickcheck.Type_class.t val gen : t QCheck2.Gen.t - val encode_pb : t -> Pbrt.Encoder.t -> unit - val decode_pb : Pbrt.Decoder.t -> t - val encode_json : t -> Yojson.Basic.t - val decode_json : Yojson.Basic.t -> t end -val run : ?examples:'a list -> (module S with type t = 'a) -> unit + val run : ?examples:'a list -> (module S with type t = 'a) -> unit diff --git a/src/tests/roundtrip/unit_or_error.ml b/src/tests/roundtrip/unit_or_error.ml index 60775547..09a60d3a 100644 --- a/src/tests/roundtrip/unit_or_error.ml +++ b/src/tests/roundtrip/unit_or_error.ml @@ -4,12 +4,7 @@ module T = struct | Error of Error_.t [@@deriving qcheck2] - let pp = Messages.pp_unit_or_error - let equal = Messages.equal_unit_or_error - let encode_pb = Messages.encode_pb_unit_or_error - let decode_pb = Messages.decode_pb_unit_or_error - let encode_json = Messages.encode_json_unit_or_error - let decode_json = Messages.decode_json_unit_or_error + let quickcheck = Messages.quickcheck_unit_or_error end include T