generate most of the bindings

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")

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 <[email protected]>" "Simon Cruanes"]
+authors: ["Maxime Ransan <[email protected]>" "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"

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))

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)

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

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

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
 

src/runtime-qcheck/dune

@@ -0,0 +1,7 @@
+(library
+ (public_name pbrt_quickcheck)
+ (wrapped false)
+ (libraries
+  pbrt
+  (re_export qcheck)
+  yojson))

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

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})))

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

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

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;
+  }

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 *)

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