Merge pull request #194 from vch9/master

Deriver: fix recursive poly variants derivation

Author: jmid

src/ppx_deriving_qcheck/README.md

@@ -261,7 +261,22 @@ type tree = [ `Leaf of int | `Node of tree * tree ]
 
 (* ==> *)
 
-/!\ FIXME: https://github.com/vch9/ppx_deriving_qcheck/issues/7 /!\
+let gen_tree =
+  (QCheck.Gen.sized @@ QCheck.Gen.fix (fun self -> function
+  | 0 ->
+    QCheck.Gen.frequency [
+	  ( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int);
+    ]
+  | n ->
+    QCheck.Gen.frequency [
+      ( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int);
+      ( 1,
+           QCheck.Gen.map (fun gen0 -> `Node gen0)
+             (QCheck.Gen.map
+               (fun (gen0, gen1) -> (gen0, gen1))
+                 (QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))
+                      ])
+            : tree QCheck.Gen.t)
 ```
 
 ## Mutual recursive types

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml

@@ -44,6 +44,12 @@ let rec longident_to_str = function
   | Lapply (lg1, lg2) ->
       Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2)
 
+let rec is_rec_typ typ_name = function
+  | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } ->
+      longident_to_str x = typ_name
+  | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ typ_name) xs
+  | _ -> false
+
 let name s =
   let prefix = "gen" in
   match s with "t" -> prefix | s -> prefix ^ "_" ^ s
@@ -309,13 +315,7 @@ and gen_from_variant ~loc typ_name rws =
   let is_rec (row : row_field) : bool =
     match row.prf_desc with
     | Rinherit _ -> false
-    | Rtag (_, _, typs) ->
-        List.exists
-          (function
-            | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } ->
-                longident_to_str x = typ_name
-            | _ -> false)
-          typs
+    | Rtag (_, _, typs) -> List.exists (is_rec_typ typ_name) typs
   in
   let to_gen ?env (row : row_field) : expression =
     let w =
@@ -347,6 +347,7 @@ and gen_from_variant ~loc typ_name rws =
   *)
   let gen = sized ~loc ~env:TypeGen.empty typ_name is_rec to_gen rws in
   let typ_t = A.ptyp_constr (A.Located.mk @@ Lident typ_name) [] in
+  (* TODO: mutualize this ident for https://github.com/c-cube/qcheck/issues/190 *)
   let typ_gen = A.Located.mk @@ Lident "QCheck.Gen.t" in
   let typ = A.ptyp_constr typ_gen [ typ_t ] in
   [%expr ([%e gen] : [%t typ])]
@@ -385,12 +386,6 @@ and gen_from_arrow ~loc ~env left right =
     QCheck.fun_nary QCheck.Tuple.([%e observable left] @-> [%e obs]) [%e arb]
     |> QCheck.gen]
 
-let rec is_rec_typ typ_name = function
-  | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } ->
-      longident_to_str x = typ_name
-  | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ typ_name) xs
-  | _ -> false
-
 let gen_from_kind_variant ~loc ~env typ_name xs =
   let (module A) = Ast_builder.make loc in
   let is_rec (constr : constructor_declaration) : bool =

test/ppx_deriving_qcheck/deriver/test.ml

@@ -792,6 +792,43 @@ let test_weight_konstrs () =
   in
   check_eq ~expected ~actual "deriving weight konstrs"
 
+(* Regression test: https://github.com/c-cube/qcheck/issues/187 *)
+let test_recursive_poly_variant () =
+  let expected =
+    [
+      [%stri
+        let gen_tree =
+          (QCheck.Gen.sized
+           @@ QCheck.Gen.fix (fun self -> function
+                | 0 ->
+                    QCheck.Gen.frequency
+                      [
+                        ( 1,
+                          QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int
+                        );
+                      ]
+                | n ->
+                    QCheck.Gen.frequency
+                      [
+                        ( 1,
+                          QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int
+                        );
+                        ( 1,
+                          QCheck.Gen.map
+                            (fun gen0 -> `Node gen0)
+                            (QCheck.Gen.map
+                               (fun (gen0, gen1) -> (gen0, gen1))
+                               (QCheck.Gen.pair (self (n / 2)) (self (n / 2))))
+                        );
+                      ])
+            : tree QCheck.Gen.t)];
+    ]
+  in
+  let actual =
+    f @@ extract [%stri type tree = [ `Leaf of int | `Node of tree * tree ]]
+  in
+  check_eq ~expected ~actual "deriving recursive polymorphic variants"
+
 let () =
   Alcotest.(
     run
@@ -830,5 +867,9 @@ let () =
             test_case "deriving fun list" `Quick test_fun_list;
             test_case "deriving fun n" `Quick test_fun_n;
             test_case "deriving fun tuple" `Quick test_fun_tuple;
+            test_case
+              "deriving rec poly variants"
+              `Quick
+              test_recursive_poly_variant;
           ] );
       ])