From 0af542e59fe4fc3d8ce397fce3851d135eee5cb3 Mon Sep 17 00:00:00 2001
From: Kakadu <Kakadu@pm.me>
Date: Thu, 21 Nov 2024 22:44:14 +0300
Subject: [PATCH] Add a test for mutual recursion with records

Signed-off-by: Kakadu <Kakadu@pm.me>
---
 .../deriver/qcheck/test_textual.ml            | 32 +++++------
 test/ppx_deriving_qcheck/deriver/qcheck2/dune |  1 +
 .../deriver/qcheck2/test_mutual.ml            | 54 +++++++++++++++++++
 3 files changed, 71 insertions(+), 16 deletions(-)
 create mode 100644 test/ppx_deriving_qcheck/deriver/qcheck2/test_mutual.ml

diff --git a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml b/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml
index 4ba46d1f..063968ad 100644
--- a/test/ppx_deriving_qcheck/deriver/qcheck/test_textual.ml
+++ b/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 =
diff --git a/test/ppx_deriving_qcheck/deriver/qcheck2/dune b/test/ppx_deriving_qcheck/deriver/qcheck2/dune
index 091a1bfd..bfd4b6e0 100644
--- a/test/ppx_deriving_qcheck/deriver/qcheck2/dune
+++ b/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)))
diff --git a/test/ppx_deriving_qcheck/deriver/qcheck2/test_mutual.ml b/test/ppx_deriving_qcheck/deriver/qcheck2/test_mutual.ml
new file mode 100644
index 00000000..8bf35478
--- /dev/null
+++ b/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;
+
+             ])]