Add [@@deriving qcheck] support in interface files

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml

@@ -621,6 +621,61 @@ let derive_arbs ~loc xs =
   in
   gens @ List.map derive_arb flatten_gens
 
+(** {2. Signature derivation} *)
+
+(** [derive_gen_sigs ~version ~loc xs] creates generator signatures for type
+    declarations in [xs]. The signatures can either use [QCheck.Gen.t] or
+    [QCheck2.Gen.t] based on [version]. *)
+let derive_gen_sigs ~version ~loc ((_rf, tds) : rec_flag * type_declaration list) : signature =
+  let (module A) = Ast_builder.make loc in
+  let gen_t = G.ty version in
+  let sig_of_td td =
+    let ty_name = td.ptype_name.txt in
+    let gen_name = name ty_name in
+    let params = List.map fst td.ptype_params in
+    let applied_type =
+      A.ptyp_constr (A.Located.mk (Lident ty_name)) params
+    in
+    let return_type =
+      A.ptyp_constr (A.Located.mk gen_t) [applied_type]
+    in
+    let gen_type =
+      List.fold_right (fun param acc ->
+        A.ptyp_arrow Nolabel (A.ptyp_constr (A.Located.mk gen_t) [param]) acc
+      ) params return_type
+    in
+    A.psig_value
+      (A.value_description ~name:(A.Located.mk gen_name) ~type_:gen_type ~prim:[])
+  in
+  List.map sig_of_td tds
+
+(** [derive_arb_sigs ~loc xs] creates generator and arbitrary signatures for
+    type declarations in [xs]. *)
+let derive_arb_sigs ~loc ((_rf, tds) as xs) : signature =
+  let gen_sigs = derive_gen_sigs ~version:`QCheck ~loc xs in
+  let (module A) = Ast_builder.make loc in
+  let gen_t = G.ty `QCheck in
+  let arb_t = Ldot (Lident "QCheck", "arbitrary") in
+  let arb_sig_of_td td =
+    let ty_name = td.ptype_name.txt in
+    let arb_name = name_gen_to_arb (name ty_name) in
+    let params = List.map fst td.ptype_params in
+    let applied_type =
+      A.ptyp_constr (A.Located.mk (Lident ty_name)) params
+    in
+    let return_type =
+      A.ptyp_constr (A.Located.mk arb_t) [applied_type]
+    in
+    let arb_type =
+      List.fold_right (fun param acc ->
+        A.ptyp_arrow Nolabel (A.ptyp_constr (A.Located.mk gen_t) [param]) acc
+      ) params return_type
+    in
+    A.psig_value
+      (A.value_description ~name:(A.Located.mk arb_name) ~type_:arb_type ~prim:[])
+  in
+  gen_sigs @ List.map arb_sig_of_td tds
+
 (** {2. Ppxlib machinery} *)
 
 let create_gens version ~ctxt (decls : rec_flag * type_declaration list) : structure =
@@ -631,10 +686,26 @@ let create_arbs ~ctxt (decls : rec_flag * type_declaration list) : structure =
   let loc = Expansion_context.Deriver.derived_item_loc ctxt in
   derive_arbs ~loc decls
 
+let create_gen_sigs version ~ctxt (decls : rec_flag * type_declaration list) : signature =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  derive_gen_sigs ~version ~loc decls
+
+let create_arb_sigs ~ctxt (decls : rec_flag * type_declaration list) : signature =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  derive_arb_sigs ~loc decls
+
 let gen_expander_qcheck = Deriving.Generator.V2.make_noarg create_arbs
 
 let gen_expander_qcheck2 = Deriving.Generator.V2.make_noarg (create_gens `QCheck2)
 
-let _ = Deriving.add "qcheck" ~str_type_decl:gen_expander_qcheck
+let sig_expander_qcheck = Deriving.Generator.V2.make_noarg create_arb_sigs
+
+let sig_expander_qcheck2 = Deriving.Generator.V2.make_noarg (create_gen_sigs `QCheck2)
+
+let _ = Deriving.add "qcheck"
+    ~str_type_decl:gen_expander_qcheck
+    ~sig_type_decl:sig_expander_qcheck
 
-let _ = Deriving.add "qcheck2" ~str_type_decl:gen_expander_qcheck2
+let _ = Deriving.add "qcheck2"
+    ~str_type_decl:gen_expander_qcheck2
+    ~sig_type_decl:sig_expander_qcheck2

src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli

@@ -16,3 +16,21 @@ val derive_arbs :
   structure
 (** [derive_arbs ~loc xs] creates generators for type declaration in [xs] and
     use these lasts to build [QCheck.arbitrary]. *)
+
+val derive_gen_sigs :
+  version:[`QCheck | `QCheck2] ->
+  loc:location ->
+  rec_flag * type_declaration list ->
+  signature
+(** [derive_gen_sigs ~version ~loc xs] creates generator signatures for type
+    declarations in [xs].
+
+    The signatures can either use [QCheck.Gen.t] or [QCheck2.Gen.t] based on
+    [version]. *)
+
+val derive_arb_sigs :
+  loc:location ->
+  rec_flag * type_declaration list ->
+  signature
+(** [derive_arb_sigs ~loc xs] creates generator and arbitrary signatures for
+    type declarations in [xs]. *)

test/ppx_deriving_qcheck/deriver/qcheck/dune

@@ -2,6 +2,7 @@
  (package ppx_deriving_qcheck)
  (names
    test_textual
+   test_textual_sig
    test_primitives
    test_qualified_names
    test_recursive

test/ppx_deriving_qcheck/deriver/qcheck/test_textual_sig.ml

@@ -0,0 +1,102 @@
+(** Module test for ppx_deriving_qcheck signature derivation *)
+open Ppxlib
+
+let loc = Location.none
+
+let f = Ppx_deriving_qcheck.derive_arb_sigs ~loc
+
+let extract stri =
+  match stri.pstr_desc with Pstr_type (x, y) -> (x, y) | _ -> assert false
+
+let check_eq ~expected ~actual name =
+  let f x = Format.asprintf "%a" Ppxlib.Pprintast.signature x in
+  Alcotest.(check string) name (f expected) (f actual)
+
+let test_simple () =
+  let expected =
+    [
+      [%sigi: val gen : t QCheck.Gen.t];
+      [%sigi: val arb : t QCheck.arbitrary];
+    ]
+  in
+  let actual = f @@ extract [%stri type t = int] in
+  check_eq ~expected ~actual "sig for simple type"
+
+let test_named () =
+  let expected =
+    [
+      [%sigi: val gen_color : color QCheck.Gen.t];
+      [%sigi: val arb_color : color QCheck.arbitrary];
+    ]
+  in
+  let actual = f @@ extract [%stri type color = Red | Green | Blue] in
+  check_eq ~expected ~actual "sig for named type"
+
+let test_parametrized () =
+  let expected =
+    [
+      [%sigi: val gen : 'a QCheck.Gen.t -> 'a t QCheck.Gen.t];
+      [%sigi: val arb : 'a QCheck.Gen.t -> 'a t QCheck.arbitrary];
+    ]
+  in
+  let actual = f @@ extract [%stri type 'a t = 'a list] in
+  check_eq ~expected ~actual "sig for parametrized type"
+
+let test_two_params () =
+  let expected =
+    [
+      [%sigi: val gen : 'a QCheck.Gen.t -> 'b QCheck.Gen.t -> ('a, 'b) t QCheck.Gen.t];
+      [%sigi: val arb : 'a QCheck.Gen.t -> 'b QCheck.Gen.t -> ('a, 'b) t QCheck.arbitrary];
+    ]
+  in
+  let actual = f @@ extract [%stri type ('a, 'b) t = 'a * 'b] in
+  check_eq ~expected ~actual "sig for two-parameter type"
+
+let test_mutual () =
+  let expected =
+    [
+      [%sigi: val gen_tree : 'a QCheck.Gen.t -> 'a tree QCheck.Gen.t];
+      [%sigi: val gen_forest : 'a QCheck.Gen.t -> 'a forest QCheck.Gen.t];
+      [%sigi: val arb_tree : 'a QCheck.Gen.t -> 'a tree QCheck.arbitrary];
+      [%sigi: val arb_forest : 'a QCheck.Gen.t -> 'a forest QCheck.arbitrary];
+    ]
+  in
+  let actual =
+    f
+    @@ extract
+         [%stri
+           type 'a tree = Node of ('a * 'a forest)
+
+           and 'a forest = Nil | Cons of ('a tree * 'a forest)]
+  in
+  check_eq ~expected ~actual "sig for mutual recursive types"
+
+let test_abstract () =
+  let expected =
+    [
+      [%sigi: val gen : t QCheck.Gen.t];
+      [%sigi: val arb : t QCheck.arbitrary];
+    ]
+  in
+  let actual = f (Nonrecursive, [Ast_builder.Default.type_declaration
+    ~loc ~name:{txt = "t"; loc}
+    ~params:[] ~cstrs:[] ~kind:Ptype_abstract
+    ~private_:Public ~manifest:None])
+  in
+  check_eq ~expected ~actual "sig for abstract type"
+
+let () =
+  Alcotest.(
+    run
+      "ppx_deriving_qcheck sig tests"
+      [
+        ( "deriving generator sig",
+          [
+            test_case "sig for simple type" `Quick test_simple;
+            test_case "sig for named type" `Quick test_named;
+            test_case "sig for parametrized type" `Quick test_parametrized;
+            test_case "sig for two-parameter type" `Quick test_two_params;
+            test_case "sig for mutual recursive types" `Quick test_mutual;
+            test_case "sig for abstract type" `Quick test_abstract;
+          ] );
+      ])

test/ppx_deriving_qcheck/deriver/qcheck2/dune

@@ -2,6 +2,7 @@
  (package ppx_deriving_qcheck)
  (names
    test_textual
+   test_textual_sig
    test_primitives
    test_qualified_names
    test_recursive

test/ppx_deriving_qcheck/deriver/qcheck2/test_textual_sig.ml

@@ -0,0 +1,81 @@
+(** Module test for ppx_deriving_qcheck2 signature derivation *)
+open Ppxlib
+
+let loc = Location.none
+
+let f = Ppx_deriving_qcheck.derive_gen_sigs ~version:`QCheck2 ~loc
+
+let extract stri =
+  match stri.pstr_desc with Pstr_type (x, y) -> (x, y) | _ -> assert false
+
+let check_eq ~expected ~actual name =
+  let f x = Format.asprintf "%a" Ppxlib.Pprintast.signature x in
+  Alcotest.(check string) name (f expected) (f actual)
+
+let test_simple () =
+  let expected = [ [%sigi: val gen : t QCheck2.Gen.t] ] in
+  let actual = f @@ extract [%stri type t = int] in
+  check_eq ~expected ~actual "sig for simple type"
+
+let test_named () =
+  let expected = [ [%sigi: val gen_color : color QCheck2.Gen.t] ] in
+  let actual = f @@ extract [%stri type color = Red | Green | Blue] in
+  check_eq ~expected ~actual "sig for named type"
+
+let test_parametrized () =
+  let expected =
+    [ [%sigi: val gen : 'a QCheck2.Gen.t -> 'a t QCheck2.Gen.t] ]
+  in
+  let actual = f @@ extract [%stri type 'a t = 'a list] in
+  check_eq ~expected ~actual "sig for parametrized type"
+
+let test_two_params () =
+  let expected =
+    [
+      [%sigi: val gen : 'a QCheck2.Gen.t -> 'b QCheck2.Gen.t -> ('a, 'b) t QCheck2.Gen.t];
+    ]
+  in
+  let actual = f @@ extract [%stri type ('a, 'b) t = 'a * 'b] in
+  check_eq ~expected ~actual "sig for two-parameter type"
+
+let test_mutual () =
+  let expected =
+    [
+      [%sigi: val gen_tree : 'a QCheck2.Gen.t -> 'a tree QCheck2.Gen.t];
+      [%sigi: val gen_forest : 'a QCheck2.Gen.t -> 'a forest QCheck2.Gen.t];
+    ]
+  in
+  let actual =
+    f
+    @@ extract
+         [%stri
+           type 'a tree = Node of ('a * 'a forest)
+
+           and 'a forest = Nil | Cons of ('a tree * 'a forest)]
+  in
+  check_eq ~expected ~actual "sig for mutual recursive types"
+
+let test_abstract () =
+  let expected = [ [%sigi: val gen : t QCheck2.Gen.t] ] in
+  let actual = f (Nonrecursive, [Ast_builder.Default.type_declaration
+    ~loc ~name:{txt = "t"; loc}
+    ~params:[] ~cstrs:[] ~kind:Ptype_abstract
+    ~private_:Public ~manifest:None])
+  in
+  check_eq ~expected ~actual "sig for abstract type"
+
+let () =
+  Alcotest.(
+    run
+      "ppx_deriving_qcheck2 sig tests"
+      [
+        ( "deriving generator sig",
+          [
+            test_case "sig for simple type" `Quick test_simple;
+            test_case "sig for named type" `Quick test_named;
+            test_case "sig for parametrized type" `Quick test_parametrized;
+            test_case "sig for two-parameter type" `Quick test_two_params;
+            test_case "sig for mutual recursive types" `Quick test_mutual;
+            test_case "sig for abstract type" `Quick test_abstract;
+          ] );
+      ])