Merge pull request #295 from Kakadu/ppx-records-rec-rebase

PPX: mutual recursion with records is now compiling.

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml

@@ -252,7 +252,7 @@ let gen_sized ~loc ~env (is_rec : 'a -> bool) (to_gen : 'a -> expression) (xs :
     G.frequency ~loc (A.elist nodes)
   else
     let nodes = List.map to_gen nodes in
-    let leaves = A.elist leaves |> G.frequency ~loc 
+    let leaves = A.elist leaves |> G.frequency ~loc
     and nodes = A.elist (leaves @ nodes) |> G.frequency ~loc in
     [%expr
         match n with
@@ -541,12 +541,7 @@ let derive_gens ~version ~loc (xs : rec_flag * type_declaration list) : structur
       | `Normal gen -> [gen])
   | _, xs ->
      let typ_names = List.map (fun x -> x.ptype_name.txt) xs in
-     let env = Env.{ curr_type = ""; rec_types = []; curr_types = typ_names; version } in
-     let env =
-       List.fold_left
-         (fun env x -> add_if_rec env x x.ptype_name.txt)
-         env xs
-     in
+     let env = Env.{ curr_type = ""; rec_types = typ_names; curr_types = typ_names; version } in
      let gens =
        List.map (fun x ->
            let env = { env with curr_type = x.ptype_name.txt }in

test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml

@@ -118,7 +118,7 @@ let test_int64' () =
  *     ]
  *   in
  *   let actual = f @@ extract [%stri type t = Bytes.t ] in
- * 
+ *
  *   check_eq ~expected ~actual "deriving int64" *)
 
 let test_tuple () =
@@ -820,28 +820,28 @@ let test_unused_variable () =
           | _ ->
             QCheck.Gen.frequency
               [(1, (QCheck.Gen.pure A));
-               (1, (QCheck.Gen.map (fun gen0 -> B gen0) gen_myint))]
-        and gen_myint = QCheck.Gen.nat
-      ];
-      [%stri
-       let gen_c = QCheck.Gen.sized gen_c_sized
+               (1, (QCheck.Gen.map (fun gen0 -> B gen0) (gen_myint_sized (n / 2))))]
+        and gen_myint_sized _n = QCheck.Gen.nat
       ];
+      [%stri let gen_c = QCheck.Gen.sized gen_c_sized];
+      [%stri let gen_myint = QCheck.Gen.sized gen_myint_sized];
       [%stri let arb_c_sized n = QCheck.make @@ (gen_c_sized n)];
-      [%stri let arb_myint = QCheck.make @@ gen_myint];
+      [%stri let arb_myint_sized _n = QCheck.make @@ (gen_myint_sized _n)];
       [%stri let arb_c = QCheck.make @@ gen_c];
+      [%stri let arb_myint = QCheck.make @@ gen_myint];
       [%stri
-        let rec gen_c_sized _n =
+        let rec gen_c_sized n =
           QCheck.Gen.frequency
-            [(1, (QCheck.Gen.map (fun gen0 -> A gen0) gen_myint));
-             (1, (QCheck.Gen.map (fun gen0 -> B gen0) gen_myint))]
-        and gen_myint = QCheck.Gen.nat
+            [(1, (QCheck.Gen.map (fun gen0 -> A gen0) (gen_myint_sized (n / 2))));
+             (1, (QCheck.Gen.map (fun gen0 -> B gen0) (gen_myint_sized (n / 2))))]
+        and gen_myint_sized _n = QCheck.Gen.nat
       ];
-      [%stri
-       let gen_c = QCheck.Gen.sized gen_c_sized
-      ];
-      [%stri let arb_c_sized _n = QCheck.make @@ (gen_c_sized _n)];
-      [%stri let arb_myint = QCheck.make @@ gen_myint];
+      [%stri let gen_c = QCheck.Gen.sized gen_c_sized];
+      [%stri let gen_myint = QCheck.Gen.sized gen_myint_sized];
+      [%stri let arb_c_sized n = QCheck.make @@ (gen_c_sized n)];
+      [%stri let arb_myint_sized _n = QCheck.make @@ (gen_myint_sized _n)];
       [%stri let arb_c = QCheck.make @@ gen_c];
+      [%stri let arb_myint = QCheck.make @@ gen_myint];
     ]
   in
   let actual =

test/ppx_deriving_qcheck/deriver/qcheck2/dune

@@ -7,6 +7,7 @@
    test_recursive
    test_tuple
    test_variants
+   test_mutual
    test_record)
  (libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck-core)
  (preprocess (pps ppxlib.metaquot ppx_deriving_qcheck)))

test/ppx_deriving_qcheck/deriver/qcheck2/test_mutual.ml

@@ -0,0 +1,54 @@
+open QCheck2
+open Helpers
+
+type tree = Leaf | Node of  tree * tree
+and name  = { a: tree }
+[@@deriving qcheck2]
+
+let rec pp_tree  fmt x =
+  let open Format in
+  match x with
+  | Leaf ->
+     fprintf fmt "Leaf"
+  | Node (l, r) ->
+     fprintf fmt "Node (%a, %a)"
+       (pp_tree ) l
+       (pp_tree ) r
+
+let eq_tree = Alcotest.of_pp (pp_tree )
+
+let gen_tree_ref =
+  let open Gen in
+  sized @@ fix (fun self ->
+             function
+             | 0 -> pure Leaf
+             | n ->
+                oneof [
+                    pure Leaf;
+                    map2 (fun  l r -> Node (l,r)) (self (n/2)) (self (n/2));
+             ])
+
+let test_tree_ref () =
+
+  test_compare ~msg:"gen tree <=> derivation tree"
+    ~eq:(eq_tree )
+    (gen_tree_ref) (gen_tree )
+
+let test_leaf =
+  Test.make
+    ~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)"
+    (gen_tree_sized 0)
+    (function
+     | Leaf -> true
+     | Node (Leaf, Leaf) -> true
+     | _ -> false)
+  |>
+    QCheck_alcotest.to_alcotest
+
+
+let () = Alcotest.run "Test_Recursive"
+           [("Recursive",
+             Alcotest.[
+                 test_case "test_tree_ref" `Quick test_tree_ref;
+
+             ])]