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 diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml index 8c26eef3..e501e540 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 @@ -128,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]. *) diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml index f30bedce..4ba46d1f 100644 --- a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml +++ b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml @@ -860,6 +860,41 @@ 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 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.( @@ -907,5 +942,13 @@ 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; + test_case + "deriving rec type in a type constructor inside record" + `Quick + test_faulty_is_rec_constr_decl; ] ); ])