Skip to content

Commit 6ed3441

Browse files
jmidjmid
authored
Merge pull request #208 from vch9/tests-and-fix
Deriver: more tests and some fixes
2 parents 57c9ba7 + 3ded296 commit 6ed3441

11 files changed

Lines changed: 492 additions & 26 deletions

File tree

‎src/ppx_deriving_qcheck/QCheck_generators.ml‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ open Ppxlib
55

66
(** {2. Type} *)
77

8-
let ty = "QCheck.Gen.t"
8+
let ty = Ldot (Ldot (Lident "QCheck", "Gen"), "t")
99

1010
(** {2. Primitive generators} *)
1111

@@ -21,11 +21,11 @@ let bool loc = [%expr QCheck.Gen.bool]
2121

2222
let float loc = [%expr QCheck.Gen.float]
2323

24-
let int32 loc = [%expr QCheck.Gen.int32]
24+
let int32 loc = [%expr QCheck.Gen.ui32]
2525

26-
let int64 loc = [%expr QCheck.Gen.int64]
26+
let int64 loc = [%expr QCheck.Gen.ui64]
2727

28-
let option ~loc e = [%expr QCheck.Gen.option [%e e]]
28+
let option ~loc e = [%expr QCheck.Gen.opt [%e e]]
2929

3030
let list ~loc e = [%expr QCheck.Gen.list [%e e]]
3131

‎src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -318,7 +318,7 @@ and gen_from_variant ~loc ~env rws =
318318
in
319319
let gen = gen_sized ~loc is_rec to_gen rws in
320320
let typ_t = A.ptyp_constr (A.Located.mk @@ Lident env.curr_type) [] in
321-
let typ_gen = A.Located.mk @@ Lident G.ty in
321+
let typ_gen = A.Located.mk G.ty in
322322
let typ = A.ptyp_constr typ_gen [ typ_t ] in
323323
[%expr ([%e gen] : [%t typ])]
324324

‎test/ppx_deriving_qcheck/deriver/dune‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,11 @@
1-
(test
2-
(name test)
3-
(modules test)
4-
(libraries alcotest ppxlib ppx_deriving_qcheck qcheck)
5-
(preprocess (pps ppxlib.metaquot)))
6-
7-
(test
8-
(name test_qualified_names)
9-
(modules test_qualified_names)
10-
(libraries qcheck)
11-
(preprocess (pps ppx_deriving_qcheck)))
1+
(tests
2+
(names
3+
test_textual
4+
test_primitives
5+
test_qualified_names
6+
test_recursive
7+
test_tuple
8+
test_variants
9+
test_record)
10+
(libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck)
11+
(preprocess (pps ppxlib.metaquot ppx_deriving_qcheck)))

‎test/ppx_deriving_qcheck/deriver/helpers.ml‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
open QCheck
2+
3+
(** {1. Helpers} *)
4+
5+
let seed = [| 42 |]
6+
7+
let generate gen = Gen.generate ~n:20 ~rand:(Random.State.make seed) gen
8+
9+
(** [test_compare msg eq gen_ref gen_cand] will generate with the same seed
10+
[gen_ref] and [gen_cand], and test with Alcotest that both generators
11+
generates the same values. *)
12+
let test_compare ~msg ~eq gen_ref gen_candidate =
13+
let expected = generate gen_ref in
14+
let actual = generate gen_candidate in
15+
Alcotest.(check (list eq)) msg expected actual

‎test/ppx_deriving_qcheck/deriver/test_primitives.ml‎

Lines changed: 89 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,89 @@
1+
open QCheck
2+
open Helpers
3+
4+
(** {1. Test primitives derivation} *)
5+
6+
(** {2. Tests} *)
7+
8+
type int' = int [@@deriving qcheck]
9+
10+
let test_int () =
11+
test_compare ~msg:"Gen.int <=> deriving int" ~eq:Alcotest.int Gen.int gen_int'
12+
13+
type unit' = unit [@@deriving qcheck]
14+
15+
(* Pretty useless though, but, meh *)
16+
let test_unit () =
17+
test_compare ~msg:"Gen.unit <=> deriving unit" ~eq:Alcotest.unit Gen.unit gen_unit'
18+
19+
type string' = string [@@deriving qcheck]
20+
21+
let test_string () =
22+
test_compare ~msg:"Gen.string <=> deriving string" ~eq:Alcotest.string Gen.string gen_string'
23+
24+
type char' = char [@@deriving qcheck]
25+
26+
let test_char () =
27+
test_compare ~msg:"Gen.char <=> deriving char" ~eq:Alcotest.char Gen.char gen_char'
28+
29+
type bool' = bool [@@deriving qcheck]
30+
31+
let test_bool () =
32+
test_compare ~msg:"Gen.bool <=> deriving bool" ~eq:Alcotest.bool Gen.bool gen_bool'
33+
34+
type float' = float [@@deriving qcheck]
35+
36+
let test_float () =
37+
test_compare ~msg:"Gen.float <=> deriving float" ~eq:(Alcotest.float 0.) Gen.float gen_float'
38+
39+
type int32' = int32 [@@deriving qcheck]
40+
41+
let test_int32 () =
42+
test_compare ~msg:"Gen.int32 <=> deriving int32" ~eq:Alcotest.int32 Gen.ui32 gen_int32'
43+
44+
type int64' = int64 [@@deriving qcheck]
45+
46+
let test_int64 () =
47+
test_compare ~msg:"Gen.int64 <=> deriving int64" ~eq:Alcotest.int64 Gen.ui64 gen_int64'
48+
49+
type 'a option' = 'a option [@@deriving qcheck]
50+
51+
let test_option () =
52+
let zero = Gen.pure 0 in
53+
test_compare ~msg:"Gen.opt <=> deriving opt"
54+
~eq:Alcotest.(option int)
55+
(Gen.opt zero) (gen_option' zero)
56+
57+
type 'a array' = 'a array [@@deriving qcheck]
58+
59+
let test_array () =
60+
let zero = Gen.pure 0 in
61+
test_compare ~msg:"Gen.array <=> deriving array"
62+
~eq:Alcotest.(array int)
63+
(Gen.array zero) (gen_array' zero)
64+
65+
type 'a list' = 'a list [@@deriving qcheck]
66+
67+
let test_list () =
68+
let zero = Gen.pure 0 in
69+
test_compare ~msg:"Gen.list <=> deriving list"
70+
~eq:Alcotest.(list int)
71+
(Gen.list zero) (gen_list' zero)
72+
73+
(** {2. Execute tests} *)
74+
75+
let () = Alcotest.run "Test_Primitives"
76+
[("Primitives",
77+
Alcotest.[
78+
test_case "test_int" `Quick test_int;
79+
test_case "test_unit" `Quick test_unit;
80+
test_case "test_string" `Quick test_string;
81+
test_case "test_char" `Quick test_char;
82+
test_case "test_bool" `Quick test_bool;
83+
test_case "test_float" `Quick test_float;
84+
test_case "test_int32" `Quick test_int32;
85+
test_case "test_int64" `Quick test_int64;
86+
test_case "test_option" `Quick test_option;
87+
test_case "test_array" `Quick test_array;
88+
test_case "test_list" `Quick test_list;
89+
])]

‎test/ppx_deriving_qcheck/deriver/test_qualified_names.ml‎

Lines changed: 35 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,37 @@
1-
module Q = struct
2-
type t = int
3-
[@@deriving qcheck]
1+
open QCheck
2+
open Helpers
3+
4+
module type S = sig
5+
type t = int
6+
7+
val gen : int QCheck.Gen.t
8+
end
9+
10+
module Q : S = struct
11+
type t = int [@@deriving qcheck]
12+
end
13+
14+
module F (X : S) = struct
15+
type t = X.t [@@deriving qcheck]
416
end
517

6-
type t = Q.t
7-
[@@deriving qcheck]
18+
module G = F (Q)
19+
20+
type t = Q.t [@@deriving qcheck]
21+
22+
type u = G.t [@@deriving qcheck]
23+
24+
let test_module () =
25+
test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int Gen.int gen
26+
27+
let test_functor () =
28+
test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int Gen.int gen_u
29+
30+
(** {2. Execute tests} *)
31+
32+
let () = Alcotest.run "Test_Qualified_names"
33+
[("Qualified names",
34+
Alcotest.[
35+
test_case "test_module" `Quick test_module;
36+
test_case "test_functor" `Quick test_functor
37+
])]

‎test/ppx_deriving_qcheck/deriver/test_record.ml‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
1+
open QCheck
2+
open Helpers
3+
4+
type env = {
5+
rec_types : string list;
6+
curr_types : string list;
7+
curr_type : string
8+
}
9+
[@@deriving qcheck]
10+
11+
let pp_env fmt {rec_types; curr_types; curr_type} =
12+
let open Format in
13+
fprintf fmt {|{
14+
rec_types = [%a];
15+
curr_types = [%a];
16+
curr_type = [%s];
17+
}|}
18+
(pp_print_list pp_print_string) rec_types
19+
(pp_print_list pp_print_string) curr_types
20+
curr_type
21+
22+
let eq_env = Alcotest.of_pp pp_env
23+
24+
let gen_env_ref =
25+
let open Gen in
26+
map3 (fun rec_types curr_types curr_type ->
27+
{ rec_types; curr_types; curr_type })
28+
(list string) (list string) string
29+
30+
let test_env () =
31+
test_compare ~msg:"gen_env ref <=> deriving env"
32+
~eq:eq_env gen_env_ref gen_env
33+
34+
type color = Color of { red : float; green : float; blue : float }
35+
[@@deriving qcheck]
36+
37+
let pp_color fmt (Color {red; green; blue}) =
38+
let open Format in
39+
fprintf fmt {|Color {
40+
red = %a;
41+
green = %a;
42+
blue = %a;
43+
}|}
44+
pp_print_float red
45+
pp_print_float green
46+
pp_print_float blue
47+
48+
let eq_color = Alcotest.of_pp pp_color
49+
50+
let gen_color_ref =
51+
let open Gen in
52+
map3 (fun red green blue -> Color {red; green; blue}) float float float
53+
54+
let test_color () =
55+
test_compare ~msg:"gen_color ref <=> deriving color"
56+
~eq:eq_color gen_color_ref gen_color
57+
58+
(** {2. Execute tests} *)
59+
60+
let () = Alcotest.run "Test_Record"
61+
[("Record",
62+
Alcotest.[
63+
test_case "test_env" `Quick test_env;
64+
test_case "test_color" `Quick test_color;
65+
])]

‎test/ppx_deriving_qcheck/deriver/test_recursive.ml‎

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
open QCheck
2+
open Helpers
3+
4+
type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree
5+
[@@deriving qcheck]
6+
7+
let rec pp_tree pp fmt x =
8+
let open Format in
9+
match x with
10+
| Leaf ->
11+
fprintf fmt "Leaf"
12+
| Node (x, l, r) ->
13+
fprintf fmt "Node (%a, %a, %a)"
14+
pp x
15+
(pp_tree pp) l
16+
(pp_tree pp) r
17+
18+
let eq_tree pp = Alcotest.of_pp (pp_tree pp)
19+
20+
let gen_tree_ref gen =
21+
let open Gen in
22+
sized @@ fix (fun self ->
23+
function
24+
| 0 -> pure Leaf
25+
| n ->
26+
oneof [
27+
pure Leaf;
28+
map3 (fun x l r -> Node (x,l,r)) gen (self (n/2)) (self (n/2));
29+
])
30+
31+
let gen_tree_candidate = gen_tree
32+
33+
let test_tree_ref () =
34+
let gen = Gen.int in
35+
test_compare ~msg:"gen tree <=> derivation tree"
36+
~eq:(eq_tree Format.pp_print_int)
37+
(gen_tree_ref gen) (gen_tree gen)
38+
39+
let test_leaf =
40+
Test.make
41+
~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)"
42+
(make (gen_tree_sized Gen.int 0))
43+
(function
44+
| Leaf -> true
45+
| Node (_, Leaf, Leaf) -> true
46+
| _ -> false)
47+
|>
48+
QCheck_alcotest.to_alcotest
49+
50+
(* A slight error has been found here:
51+
If the type is named `list` then `'a list` will be derived with the
52+
QCheck generator `list` instead of the `gen_list_sized`.
53+
54+
This could lead to a design choice:
55+
- do we allow overriding primitive types?
56+
- do we prioritize `Env.curr_types` over primitive types?
57+
*)
58+
type 'a my_list = Cons of 'a * 'a my_list | Nil
59+
[@@deriving qcheck]
60+
61+
let rec length = function
62+
| Nil -> 0
63+
| Cons (_, xs) -> 1 + length xs
64+
65+
let test_length =
66+
Test.make
67+
~name:"gen_list_sized n >>= fun l -> length l <= n"
68+
small_int
69+
(fun n ->
70+
let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in
71+
length l <= n)
72+
|>
73+
QCheck_alcotest.to_alcotest
74+
75+
let () = Alcotest.run "Test_Recursive"
76+
[("Recursive",
77+
Alcotest.[
78+
test_case "test_tree_ref" `Quick test_tree_ref;
79+
test_leaf
80+
])]

test/ppx_deriving_qcheck/deriver/test.ml renamed to test/ppx_deriving_qcheck/deriver/test_textual.ml

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -55,25 +55,25 @@ let test_bool () =
5555
check_eq ~expected ~actual "deriving bool"
5656

5757
let test_int32 () =
58-
let expected = [ [%stri let gen = QCheck.Gen.int32] ] in
58+
let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
5959
let actual = f @@ extract [%stri type t = int32] in
6060

6161
check_eq ~expected ~actual "deriving int32"
6262

6363
let test_int32' () =
64-
let expected = [ [%stri let gen = QCheck.Gen.int32] ] in
64+
let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
6565
let actual = f @@ extract [%stri type t = Int32.t] in
6666

6767
check_eq ~expected ~actual "deriving int32'"
6868

6969
let test_int64 () =
70-
let expected = [ [%stri let gen = QCheck.Gen.int64] ] in
70+
let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
7171
let actual = f @@ extract [%stri type t = int64] in
7272

7373
check_eq ~expected ~actual "deriving int64"
7474

7575
let test_int64' () =
76-
let expected = [ [%stri let gen = QCheck.Gen.int64] ] in
76+
let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
7777
let actual = f @@ extract [%stri type t = Int64.t] in
7878

7979
check_eq ~expected ~actual "deriving int64'"
@@ -147,7 +147,7 @@ let test_tuple () =
147147
check_eq ~expected ~actual "deriving tuples"
148148

149149
let test_option () =
150-
let expected = [ [%stri let gen = QCheck.Gen.option QCheck.Gen.int] ] in
150+
let expected = [ [%stri let gen = QCheck.Gen.opt QCheck.Gen.int] ] in
151151
let actual = f' @@ extract' [ [%stri type t = int option] ] in
152152
check_eq ~expected ~actual "deriving option"
153153

0 commit comments

Comments
 (0)