Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix is_rec_typ deriver bug(s) #272

Merged
merged 5 commits into from
May 2, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 4 additions & 3 deletions src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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]. *)
Expand Down
43 changes: 43 additions & 0 deletions test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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.(
Expand Down Expand Up @@ -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;
] );
])