diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml index 8ed6fd3d..9ec0bea5 100644 --- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml +++ b/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 diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli index 09d289f6..33713529 100644 --- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli +++ b/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]. *) diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/dune b/test/ppx_deriving_qcheck/deriver/qcheck/dune index 091a1bfd..a020e037 100644 --- a/test/ppx_deriving_qcheck/deriver/qcheck/dune +++ b/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 diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual_sig.ml b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual_sig.ml new file mode 100644 index 00000000..998dad7f --- /dev/null +++ b/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; + ] ); + ]) diff --git a/test/ppx_deriving_qcheck/deriver/qcheck2/dune b/test/ppx_deriving_qcheck/deriver/qcheck2/dune index bfd4b6e0..33457107 100644 --- a/test/ppx_deriving_qcheck/deriver/qcheck2/dune +++ b/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 diff --git a/test/ppx_deriving_qcheck/deriver/qcheck2/test_textual_sig.ml b/test/ppx_deriving_qcheck/deriver/qcheck2/test_textual_sig.ml new file mode 100644 index 00000000..cded49e7 --- /dev/null +++ b/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; + ] ); + ])