From 8685dad2eee48d93e7afd8466a17ee1fa2ac331a Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 23 Feb 2023 15:08:44 +0100 Subject: [PATCH 1/5] correct is_rec_typ --- src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml index 8c26eef3..c9c02adb 100644 --- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml +++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml @@ -111,8 +111,9 @@ let rec longident_to_str = function Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2) let rec is_rec_typ env = function - | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } -> - List.exists (fun typ_name -> longident_to_str x = typ_name) env.Env.curr_types + | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, args); _ } -> + List.exists (fun typ_name -> longident_to_str x = typ_name) env.Env.curr_types || + List.exists (is_rec_typ env) args | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ env) xs | { ptyp_desc = Ptyp_variant (rws, _, _); _ } -> List.exists (is_rec_row_field env) rws From 0c2728f0038fe228ae3645d15a4c90ed7718eef4 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 23 Feb 2023 15:09:04 +0100 Subject: [PATCH 2/5] add test case --- .../deriver/qcheck/test_textual.ml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml index f30bedce..3df4b3da 100644 --- a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml +++ b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml @@ -860,6 +860,20 @@ let test_unused_variable () = in check_eq ~expected ~actual "deriving variant with unused fuel parameter" +(* Regression test: https://github.com/c-cube/qcheck/issues/269 *) +let test_faulty_is_rec_typ_in_variant () = + let expected = + [ + [%stri let rec gen_sized n = + QCheck.Gen.map (fun gen0 -> Foo gen0) (QCheck.Gen.list (gen_sized (n / 2)))]; + [%stri let gen = QCheck.Gen.sized gen_sized]; + [%stri let arb_sized n = QCheck.make @@ (gen_sized n)]; + [%stri let arb = QCheck.make @@ gen]; + ] + in + let actual = f @@ extract [%stri type t = Foo of t list] + in + check_eq ~expected ~actual "deriving rec type in a type constructor inside variant" let () = Alcotest.( @@ -907,5 +921,9 @@ let () = "deriving variant with unused fuel parameter" `Quick test_unused_variable; + test_case + "deriving rec type in a type constructor inside variant" + `Quick + test_faulty_is_rec_typ_in_variant; ] ); ]) From 78e8baf6a82bdfd30ed77bbe29a103bad72e1bb1 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 23 Feb 2023 15:28:22 +0100 Subject: [PATCH 3/5] fix is_rec_constr_decl record case --- src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml index c9c02adb..e501e540 100644 --- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml +++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml @@ -129,7 +129,7 @@ and is_rec_row_field env rw = let is_rec_constr_decl env cd = match cd.pcd_args with | Pcstr_tuple cts -> List.exists (is_rec_typ env) cts - | _ -> false + | Pcstr_record ldcls -> List.exists (fun ldcl -> is_rec_typ env ldcl.pld_type) ldcls (** [is_rec_type_decl env typ] looks for elements of [env.curr_types] recursively in [typ]. *) From 08db79459d47240e06fe561f6d2acffa7f29cf1c Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 23 Feb 2023 15:29:05 +0100 Subject: [PATCH 4/5] add test case for is_rec_constr_decl record case --- .../deriver/qcheck/test_textual.ml | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml index 3df4b3da..4ba46d1f 100644 --- a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml +++ b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml @@ -875,6 +875,27 @@ let test_faulty_is_rec_typ_in_variant () = in check_eq ~expected ~actual "deriving rec type in a type constructor inside variant" +let test_faulty_is_rec_constr_decl () = + let expected = + [ + [%stri let rec gen_sized n = + match n with + | 0 -> QCheck.Gen.pure Foo + | _ -> + QCheck.Gen.frequency + [(1, (QCheck.Gen.pure Foo)); + (1, + (QCheck.Gen.map (fun gen0 -> Bar { baz = gen0 }) + (gen_sized (n / 2))))]]; + [%stri let gen = QCheck.Gen.sized gen_sized]; + [%stri let arb_sized n = QCheck.make @@ (gen_sized n)]; + [%stri let arb = QCheck.make @@ gen]; + ] + in + let actual = f @@ extract [%stri type t = Foo | Bar of { baz : t }] + in + check_eq ~expected ~actual "deriving rec type in a type constructor inside record" + let () = Alcotest.( run @@ -925,5 +946,9 @@ let () = "deriving rec type in a type constructor inside variant" `Quick test_faulty_is_rec_typ_in_variant; + test_case + "deriving rec type in a type constructor inside record" + `Quick + test_faulty_is_rec_constr_decl; ] ); ]) From d779d268db163f0e4914374f4be48cedace32db6 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Tue, 2 May 2023 12:16:33 +0200 Subject: [PATCH 5/5] Add CHANGELOG entry --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ebe3bc95..24196e7a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,9 @@ `Test.check_exn` honor test polarity by raising `Test_unexpected_success` when a negative test (expected to have a counter example), unexpectedly succeeds. +- fix issue with `ppx_deriving_qcheck` deriving a generator with unbound + `gen` for recursive types [#269](https://github.com/c-cube/qcheck/issues/269) + and a related issue when deriving a generator for a record type - ... ## 0.20