Deriver: more tests and some fixes

src/ppx_deriving_qcheck/QCheck_generators.ml

@@ -5,7 +5,7 @@ open Ppxlib
 
 (** {2. Type} *)
 
-let ty = "QCheck.Gen.t"
+let ty = Ldot (Ldot (Lident "QCheck", "Gen"), "t")
 
 (** {2. Primitive generators} *)
 
@@ -21,11 +21,11 @@ let bool loc = [%expr QCheck.Gen.bool]
 
 let float loc = [%expr QCheck.Gen.float]
 
-let int32 loc = [%expr QCheck.Gen.int32]
+let int32 loc = [%expr QCheck.Gen.ui32]
 
-let int64 loc = [%expr QCheck.Gen.int64]
+let int64 loc = [%expr QCheck.Gen.ui64]
 
-let option ~loc e = [%expr QCheck.Gen.option [%e e]]
+let option ~loc e = [%expr QCheck.Gen.opt [%e e]]
 
 let list ~loc e = [%expr QCheck.Gen.list [%e e]]
 

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml

@@ -318,7 +318,7 @@ and gen_from_variant ~loc ~env rws =
   in
   let gen = gen_sized ~loc is_rec to_gen rws in
   let typ_t = A.ptyp_constr (A.Located.mk @@ Lident env.curr_type) [] in
-  let typ_gen = A.Located.mk @@ Lident G.ty in
+  let typ_gen = A.Located.mk G.ty in
   let typ = A.ptyp_constr typ_gen [ typ_t ] in
   [%expr ([%e gen] : [%t typ])]
 

test/ppx_deriving_qcheck/deriver/dune

@@ -1,11 +1,11 @@
-(test
- (name test)
- (modules test)
- (libraries alcotest ppxlib ppx_deriving_qcheck qcheck)
- (preprocess (pps ppxlib.metaquot)))
-
-(test
- (name test_qualified_names)
- (modules test_qualified_names)
- (libraries qcheck)
- (preprocess (pps ppx_deriving_qcheck)))
+(tests
+ (names
+   test_textual
+   test_primitives
+   test_qualified_names
+   test_recursive
+   test_tuple
+   test_variants
+   test_record)
+ (libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck)
+ (preprocess (pps ppxlib.metaquot ppx_deriving_qcheck)))

test/ppx_deriving_qcheck/deriver/helpers.ml

@@ -0,0 +1,15 @@
+open QCheck
+
+(** {1. Helpers} *)
+
+let seed = [| 42 |]
+
+let generate gen = Gen.generate ~n:20 ~rand:(Random.State.make seed) gen
+
+(** [test_compare msg eq gen_ref gen_cand] will generate with the same seed
+    [gen_ref] and [gen_cand], and test with Alcotest that both generators
+    generates the same values. *)
+let test_compare ~msg ~eq gen_ref gen_candidate =
+  let expected = generate gen_ref in
+  let actual = generate gen_candidate in
+  Alcotest.(check (list eq)) msg expected actual

test/ppx_deriving_qcheck/deriver/test_primitives.ml

@@ -0,0 +1,89 @@
+open QCheck
+open Helpers
+
+(** {1. Test primitives derivation} *)
+
+(** {2. Tests} *)
+
+type int' = int [@@deriving qcheck]
+
+let test_int () =
+  test_compare ~msg:"Gen.int <=> deriving int" ~eq:Alcotest.int Gen.int gen_int'
+
+type unit' = unit [@@deriving qcheck]
+
+(* Pretty useless though, but, meh *)
+let test_unit () =
+  test_compare ~msg:"Gen.unit <=> deriving unit" ~eq:Alcotest.unit Gen.unit gen_unit'
+
+type string' = string [@@deriving qcheck]
+
+let test_string () =
+  test_compare ~msg:"Gen.string <=> deriving string" ~eq:Alcotest.string Gen.string gen_string'
+
+type char' = char [@@deriving qcheck]
+
+let test_char () =
+  test_compare ~msg:"Gen.char <=> deriving char" ~eq:Alcotest.char Gen.char gen_char'
+
+type bool' = bool [@@deriving qcheck]
+
+let test_bool () =
+  test_compare ~msg:"Gen.bool <=> deriving bool" ~eq:Alcotest.bool Gen.bool gen_bool'
+
+type float' = float [@@deriving qcheck]
+
+let test_float () =
+  test_compare ~msg:"Gen.float <=> deriving float" ~eq:(Alcotest.float 0.) Gen.float gen_float'
+
+type int32' = int32 [@@deriving qcheck]
+
+let test_int32 () =
+  test_compare ~msg:"Gen.int32 <=> deriving int32" ~eq:Alcotest.int32 Gen.ui32 gen_int32'
+
+type int64' = int64 [@@deriving qcheck]
+
+let test_int64 () =
+  test_compare ~msg:"Gen.int64 <=> deriving int64" ~eq:Alcotest.int64 Gen.ui64 gen_int64'
+
+type 'a option' = 'a option [@@deriving qcheck]
+
+let test_option () =
+  let zero = Gen.pure 0 in
+  test_compare ~msg:"Gen.opt <=> deriving opt"
+    ~eq:Alcotest.(option int)
+    (Gen.opt zero) (gen_option' zero)
+
+type 'a array' = 'a array [@@deriving qcheck]
+
+let test_array () =
+  let zero = Gen.pure 0 in
+  test_compare ~msg:"Gen.array <=> deriving array"
+    ~eq:Alcotest.(array int)
+    (Gen.array zero) (gen_array' zero)
+
+type 'a list' = 'a list [@@deriving qcheck]
+
+let test_list () =
+  let zero = Gen.pure 0 in
+  test_compare ~msg:"Gen.list <=> deriving list"
+    ~eq:Alcotest.(list int)
+    (Gen.list zero) (gen_list' zero)
+
+(** {2. Execute tests} *)
+
+let () = Alcotest.run "Test_Primitives"
+           [("Primitives",
+             Alcotest.[
+                 test_case "test_int" `Quick test_int;
+                 test_case "test_unit" `Quick test_unit;
+                 test_case "test_string" `Quick test_string;
+                 test_case "test_char" `Quick test_char;
+                 test_case "test_bool" `Quick test_bool;
+                 test_case "test_float" `Quick test_float;
+                 test_case "test_int32" `Quick test_int32;
+                 test_case "test_int64" `Quick test_int64;
+                 test_case "test_option" `Quick test_option;
+                 test_case "test_array" `Quick test_array;
+                 test_case "test_list" `Quick test_list;
+           ])]

test/ppx_deriving_qcheck/deriver/test_qualified_names.ml

@@ -1,7 +1,37 @@
-module Q = struct
-   type t = int
-    [@@deriving qcheck]
+open QCheck
+open Helpers
+
+module type S = sig
+  type t = int
+
+  val gen : int QCheck.Gen.t
+end
+
+module Q : S = struct
+  type t = int [@@deriving qcheck]
+end
+
+module F (X : S) = struct
+  type t = X.t [@@deriving qcheck]
 end
 
-type t = Q.t
- [@@deriving qcheck]
+module G = F (Q)
+
+type t = Q.t [@@deriving qcheck]
+
+type u = G.t [@@deriving qcheck]
+
+let test_module () =
+  test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int Gen.int gen
+
+let test_functor () =
+  test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int Gen.int gen_u
+
+(** {2. Execute tests} *)
+
+let () = Alcotest.run "Test_Qualified_names"
+           [("Qualified names",
+             Alcotest.[
+                 test_case "test_module" `Quick test_module;
+                 test_case "test_functor" `Quick test_functor
+           ])]

test/ppx_deriving_qcheck/deriver/test_record.ml

@@ -0,0 +1,65 @@
+open QCheck
+open Helpers
+
+type env = {
+    rec_types : string list;
+    curr_types : string list;
+    curr_type : string
+  }
+[@@deriving qcheck]
+
+let pp_env fmt {rec_types; curr_types; curr_type} =
+  let open Format in
+  fprintf fmt {|{
+  rec_types = [%a];
+  curr_types = [%a];
+  curr_type = [%s];
+}|}
+    (pp_print_list pp_print_string) rec_types
+    (pp_print_list pp_print_string) curr_types
+    curr_type
+
+let eq_env = Alcotest.of_pp pp_env
+
+let gen_env_ref =
+  let open Gen in
+  map3 (fun rec_types curr_types curr_type ->
+      { rec_types; curr_types; curr_type })
+    (list string) (list string) string
+
+let test_env () =
+  test_compare ~msg:"gen_env ref <=> deriving env"
+  ~eq:eq_env gen_env_ref gen_env
+
+type color = Color of { red : float; green : float; blue : float }
+[@@deriving qcheck]
+
+let pp_color fmt (Color {red; green; blue}) =
+  let open Format in
+  fprintf fmt {|Color {
+  red = %a;
+  green = %a;
+  blue = %a;
+}|}
+    pp_print_float red
+    pp_print_float green
+    pp_print_float blue
+
+let eq_color = Alcotest.of_pp pp_color
+
+let gen_color_ref =
+  let open Gen in
+  map3 (fun red green blue -> Color {red; green; blue}) float float float
+
+let test_color () =
+  test_compare ~msg:"gen_color ref <=> deriving color"
+  ~eq:eq_color gen_color_ref gen_color
+
+(** {2. Execute tests} *)
+
+let () = Alcotest.run "Test_Record"
+           [("Record",
+             Alcotest.[
+                 test_case "test_env" `Quick test_env;
+                 test_case "test_color" `Quick test_color;
+           ])]

test/ppx_deriving_qcheck/deriver/test_recursive.ml

@@ -0,0 +1,80 @@
+open QCheck
+open Helpers
+
+type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree
+[@@deriving qcheck]
+
+let rec pp_tree pp fmt x =
+  let open Format in
+  match x with
+  | Leaf ->
+     fprintf fmt "Leaf"
+  | Node (x, l, r) ->
+     fprintf fmt "Node (%a, %a, %a)"
+       pp x
+       (pp_tree pp) l
+       (pp_tree pp) r
+
+let eq_tree pp = Alcotest.of_pp (pp_tree pp)
+
+let gen_tree_ref gen =
+  let open Gen in
+  sized @@ fix (fun self ->
+             function
+             | 0 -> pure Leaf
+             | n ->
+                oneof [
+                    pure Leaf;
+                    map3 (fun x l r -> Node (x,l,r)) gen (self (n/2)) (self (n/2));
+             ])
+
+let gen_tree_candidate = gen_tree
+
+let test_tree_ref () =
+  let gen = Gen.int in
+  test_compare ~msg:"gen tree <=> derivation tree"
+    ~eq:(eq_tree Format.pp_print_int)
+    (gen_tree_ref gen) (gen_tree gen)
+
+let test_leaf =
+  Test.make
+    ~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)"
+    (make (gen_tree_sized Gen.int 0))
+    (function
+     | Leaf -> true
+     | Node (_, Leaf, Leaf) -> true
+     | _ -> false)
+  |>
+    QCheck_alcotest.to_alcotest
+
+(* A slight error has been found here:
+   If the type is named `list` then `'a list` will be derived with the
+   QCheck generator `list` instead of the `gen_list_sized`.
+
+   This could lead to a design choice:
+   - do we allow overriding primitive types?
+   - do we prioritize `Env.curr_types` over primitive types?
+*)
+type 'a my_list = Cons of 'a * 'a my_list | Nil
+[@@deriving qcheck]
+
+let rec length = function
+  | Nil -> 0
+  | Cons (_, xs) -> 1 + length xs
+
+let test_length =
+  Test.make
+    ~name:"gen_list_sized n >>= fun l -> length l <= n"
+    small_int
+    (fun n ->
+      let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in
+      length l <= n)
+  |>
+    QCheck_alcotest.to_alcotest
+
+let () = Alcotest.run "Test_Recursive"
+           [("Recursive",
+             Alcotest.[
+                 test_case "test_tree_ref" `Quick test_tree_ref;
+                 test_leaf
+             ])]

test/ppx_deriving_qcheck/deriver/test.ml → test/ppx_deriving_qcheck/deriver/test_textual.ml

@@ -55,25 +55,25 @@ let test_bool () =
   check_eq ~expected ~actual "deriving bool"
 
 let test_int32 () =
-  let expected = [ [%stri let gen = QCheck.Gen.int32] ] in
+  let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
   let actual = f @@ extract [%stri type t = int32] in
 
   check_eq ~expected ~actual "deriving int32"
 
 let test_int32' () =
-  let expected = [ [%stri let gen = QCheck.Gen.int32] ] in
+  let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
   let actual = f @@ extract [%stri type t = Int32.t] in
 
   check_eq ~expected ~actual "deriving int32'"
 
 let test_int64 () =
-  let expected = [ [%stri let gen = QCheck.Gen.int64] ] in
+  let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
   let actual = f @@ extract [%stri type t = int64] in
 
   check_eq ~expected ~actual "deriving int64"
 
 let test_int64' () =
-  let expected = [ [%stri let gen = QCheck.Gen.int64] ] in
+  let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
   let actual = f @@ extract [%stri type t = Int64.t] in
 
   check_eq ~expected ~actual "deriving int64'"
@@ -147,7 +147,7 @@ let test_tuple () =
   check_eq ~expected ~actual "deriving tuples"
 
 let test_option () =
-  let expected = [ [%stri let gen = QCheck.Gen.option QCheck.Gen.int] ] in
+  let expected = [ [%stri let gen = QCheck.Gen.opt QCheck.Gen.int] ] in
   let actual = f' @@ extract' [ [%stri type t = int option] ] in
   check_eq ~expected ~actual "deriving option"