From 88efa3652cf36e043e47285b51f8c4bcd6585515 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Thu, 9 Dec 2021 10:41:59 +0100
Subject: [PATCH 01/10] Separate Tuple into a module

---
 .../ppx_deriving_qcheck.ml                    | 101 -------------
 src/ppx_deriving_qcheck/tuple.ml              | 140 ++++++++++++++++++
 2 files changed, 140 insertions(+), 101 deletions(-)
 create mode 100644 src/ppx_deriving_qcheck/tuple.ml

diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index 5214dc87..114fb6ec 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -121,107 +121,6 @@ let mutually_recursive_gens ~loc gens =
   let mutual_gens = A.pstr_value Recursive fake_gens in
   mutual_gens :: real_gens
 
-module Tuple = struct
-  type 'a t =
-    | Pair of 'a t * 'a t
-    | Triple of 'a * 'a * 'a
-    | Quad of 'a * 'a * 'a * 'a
-    | Elem of 'a
-
-  let rec from_list = function
-    | [ a; b; c; d ] -> Quad (a, b, c, d)
-    | [ a; b; c ] -> Triple (a, b, c)
-    | [ a; b ] -> Pair (Elem a, Elem b)
-    | [ a ] -> Elem a
-    | l ->
-        let n = List.length l / 2 in
-        let i = ref 0 in
-        let l1 =
-          List.filter
-            (fun _ ->
-              let x = !i in
-              i := x + 1;
-              x < n)
-            l
-        in
-        i := 0;
-        let l2 =
-          List.filter
-            (fun _ ->
-              let x = !i in
-              i := x + 1;
-              x >= n)
-            l
-        in
-        Pair (from_list l1, from_list l2)
-
-  let rec to_list = function
-    | Quad (a, b, c, d) -> [ a; b; c; d ]
-    | Triple (a, b, c) -> [ a; b; c ]
-    | Pair (a, b) -> to_list a @ to_list b
-    | Elem a -> [ a ]
-
-  let to_expr ~loc t =
-    let l = to_list t in
-    let (module A) = Ast_builder.make loc in
-    List.mapi
-      (fun i _ ->
-        let s = Printf.sprintf "gen%d" i in
-        A.evar s)
-      l
-    |> A.pexp_tuple
-
-  let rec nest ~loc ~pair ~triple ~quad = function
-    | Quad (a, b, c, d) -> [%expr [%e quad] [%e a] [%e b] [%e c] [%e d]]
-    | Triple (a, b, c) -> [%expr [%e triple] [%e a] [%e b] [%e c]]
-    | Pair (a, b) ->
-        [%expr
-          [%e pair]
-            [%e nest ~loc ~pair ~triple ~quad a]
-            [%e nest ~loc ~pair ~triple ~quad b]]
-    | Elem a -> a
-
-  let to_gen ~loc t =
-    let pair = [%expr QCheck.Gen.pair] in
-    let triple = [%expr QCheck.Gen.triple] in
-    let quad = [%expr QCheck.Gen.quad] in
-    nest ~loc ~pair ~triple ~quad t
-
-  let to_obs ~loc t =
-    let pair = [%expr QCheck.Observable.pair] in
-    let triple = [%expr QCheck.Observable.triple] in
-    let quad = [%expr QCheck.Observable.quad] in
-    nest ~loc ~pair ~triple ~quad t
-
-  let to_pat ~loc t =
-    let fresh_id =
-      let id = ref 0 in
-      fun () ->
-        let x = !id in
-        let () = id := x + 1 in
-        Printf.sprintf "gen%d" x
-    in
-    let (module A) = Ast_builder.make loc in
-    let rec aux = function
-      | Quad (_, _, _, _) ->
-          let a = A.pvar @@ fresh_id () in
-          let b = A.pvar @@ fresh_id () in
-          let c = A.pvar @@ fresh_id () in
-          let d = A.pvar @@ fresh_id () in
-          [%pat? [%p a], [%p b], [%p c], [%p d]]
-      | Triple (_, _, _) ->
-          let a = A.pvar @@ fresh_id () in
-          let b = A.pvar @@ fresh_id () in
-          let c = A.pvar @@ fresh_id () in
-          [%pat? [%p a], [%p b], [%p c]]
-      | Pair (a, b) ->
-          let a = aux a in
-          let b = aux b in
-          [%pat? [%p a], [%p b]]
-      | Elem _ -> A.pvar @@ fresh_id ()
-    in
-    aux t
-end
 
 let map ~loc pat expr gen =
   [%expr QCheck.Gen.map (fun [%p pat] -> [%e expr]) [%e gen]]
diff --git a/src/ppx_deriving_qcheck/tuple.ml b/src/ppx_deriving_qcheck/tuple.ml
new file mode 100644
index 00000000..09dd3b0f
--- /dev/null
+++ b/src/ppx_deriving_qcheck/tuple.ml
@@ -0,0 +1,140 @@
+open Ppxlib
+
+(** {1. Tuple } *)
+
+(** This module implements nested tuples based on QCheck tuples generators (or observables):
+    - [Gen.pair]
+    - [Gen.triple]
+    - [Gen.quad]
+
+    It can be used to nest large tuples in a generator.
+    - e.g.
+    {[
+    type t = int * int * int
+    ]}
+
+    Lets say QCheck does not have combinator to generate a triple. One has to write:
+
+    {[
+    let gen = QCheck.Gen.(map (fun ((x, y), z) -> (x, y, z) (pair (pair int int) int))
+    ]}
+
+    We copy this nesting mechanism with this module.
+ *)
+
+type 'a t =
+  | Pair of 'a t * 'a t
+  | Triple of 'a * 'a * 'a
+  | Quad of 'a * 'a * 'a * 'a
+  | Elem of 'a
+
+(** [from_list l] builds an {!'a t}, if len of [l] is greater than 4, the list
+    is split into a [Pair] of generators. *)
+let rec from_list = function
+  | [ a; b; c; d ] -> Quad (a, b, c, d)
+  | [ a; b; c ] -> Triple (a, b, c)
+  | [ a; b ] -> Pair (Elem a, Elem b)
+  | [ a ] -> Elem a
+  | l ->
+     let n = List.length l / 2 in
+     let i = ref 0 in
+     let l1 =
+       List.filter
+         (fun _ ->
+           let x = !i in
+           i := x + 1;
+           x < n)
+            l
+     in
+     i := 0;
+     let l2 =
+       List.filter
+         (fun _ ->
+           let x = !i in
+           i := x + 1;
+           x >= n)
+         l
+     in
+     Pair (from_list l1, from_list l2)
+
+let rec to_list = function
+  | Quad (a, b, c, d) -> [ a; b; c; d ]
+  | Triple (a, b, c) -> [ a; b; c ]
+  | Pair (a, b) -> to_list a @ to_list b
+  | Elem a -> [ a ]
+
+(** [to_expr ~loc t] creates a tuple expression based on [t].
+    [t] is transformed to a list, and each element from the list becomes
+    a variable referencing a generator.
+
+    - e.g.
+    to_expr (Pair (_, _)) => (gen0, gen1)
+ *)
+let to_expr ~loc t =
+  let l = to_list t in
+  let (module A) = Ast_builder.make loc in
+  List.mapi
+    (fun i _ ->
+      let s = Printf.sprintf "gen%d" i in
+      A.evar s)
+    l
+  |> A.pexp_tuple
+
+(** [nest pair triple quad t] creates a generator expression for [t] using
+
+    - [pair] to combine Pair (_, _)
+    - [triple] to combine Triple (_, _, )
+    - [quad] to combine Quad (_, _, _, _)
+*)
+let rec nest ~loc ~pair ~triple ~quad = function
+  | Quad (a, b, c, d) -> [%expr [%e quad] [%e a] [%e b] [%e c] [%e d]]
+  | Triple (a, b, c) -> [%expr [%e triple] [%e a] [%e b] [%e c]]
+  | Pair (a, b) ->
+     [%expr
+         [%e pair]
+         [%e nest ~loc ~pair ~triple ~quad a]
+         [%e nest ~loc ~pair ~triple ~quad b]]
+  | Elem a -> a
+
+(** [to_gen t] creates a Gen.t with generators' combinators *)
+let to_gen ~loc t =
+  let pair = [%expr QCheck.Gen.pair] in
+  let triple = [%expr QCheck.Gen.triple] in
+  let quad = [%expr QCheck.Gen.quad] in
+  nest ~loc ~pair ~triple ~quad t
+
+(** [to_obs t] creates a Obs.t with obsersvables' combinators *)
+let to_obs ~loc t =
+  let pair = [%expr QCheck.Observable.pair] in
+  let triple = [%expr QCheck.Observable.triple] in
+  let quad = [%expr QCheck.Observable.quad] in
+  nest ~loc ~pair ~triple ~quad t
+
+let to_pat ~loc t =
+  let fresh_id =
+    let id = ref 0 in
+    fun () ->
+    let x = !id in
+    let () = id := x + 1 in
+    Printf.sprintf "gen%d" x
+  in
+  let (module A) = Ast_builder.make loc in
+  let rec aux = function
+    | Quad (_, _, _, _) ->
+       let a = A.pvar @@ fresh_id () in
+       let b = A.pvar @@ fresh_id () in
+       let c = A.pvar @@ fresh_id () in
+       let d = A.pvar @@ fresh_id () in
+       [%pat? [%p a], [%p b], [%p c], [%p d]]
+    | Triple (_, _, _) ->
+       let a = A.pvar @@ fresh_id () in
+       let b = A.pvar @@ fresh_id () in
+       let c = A.pvar @@ fresh_id () in
+       [%pat? [%p a], [%p b], [%p c]]
+    | Pair (a, b) ->
+       let a = aux a in
+       let b = aux b in
+       [%pat? [%p a], [%p b]]
+    | Elem _ -> A.pvar @@ fresh_id ()
+  in
+  aux t

From c342d1964571709deba5c1e73d3c2cbbef6ad334 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Thu, 9 Dec 2021 11:11:34 +0100
Subject: [PATCH 02/10] Export generators primitive and combinators in module

---
 .../ppx_deriving_qcheck.ml                    | 97 ++++++++++---------
 src/ppx_deriving_qcheck/qcheck_generators.ml  | 92 ++++++++++++++++++
 src/ppx_deriving_qcheck/tuple.ml              | 25 ++---
 3 files changed, 154 insertions(+), 60 deletions(-)
 create mode 100644 src/ppx_deriving_qcheck/qcheck_generators.ml

diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index 114fb6ec..5c690d41 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -1,4 +1,7 @@
 open Ppxlib
+module G = Qcheck_generators
+module O = G.Observable
+
 
 (** TypeGen can serve as a derivation environment. The map can be used
     to remember how a type should be translated.
@@ -67,15 +70,12 @@ let gen ~loc ?(env = TypeGen.empty) lg =
   | Ldot (lg, s) -> A.(pexp_ident (Located.mk @@ Ldot (lg, name s)))
   | Lapply (_, _) -> raise (Invalid_argument "gen received an Lapply")
 
-let frequency ~loc l = [%expr QCheck.Gen.frequency [%e l]]
-
-let pure ~loc x = [%expr QCheck.Gen.pure [%e x]]
-
 let tree ~loc nodes leaves =
-  [%expr
-    QCheck.Gen.sized
-    @@ QCheck.Gen.fix (fun self -> function
-         | 0 -> [%e leaves] | n -> [%e nodes])]
+  (G.sized ~loc) @@ (G.fix ~loc) @@
+    [%expr
+        fun self ->
+        function
+        | 0 -> [%e leaves] | n -> [%e nodes]]
 
 let sized ~loc ~env typ_name (is_rec : 'a -> bool)
     (to_gen : ?env:expression TypeGen.t -> 'a -> expression) (xs : 'a list) =
@@ -88,12 +88,12 @@ let sized ~loc ~env typ_name (is_rec : 'a -> bool)
 
   if List.length nodes > 0 then
     let nodes = List.map (to_gen ~env:new_env) nodes in
-    let leaves = A.elist leaves |> frequency ~loc
-    and nodes = A.elist (leaves @ nodes) |> frequency ~loc in
+    let leaves = A.elist leaves |> G.frequency ~loc
+    and nodes = A.elist (leaves @ nodes) |> G.frequency ~loc in
     tree ~loc nodes leaves
   else
     let gens = A.elist leaves in
-    frequency ~loc gens
+    G.frequency ~loc gens
 
 let mutually_recursive_gens ~loc gens =
   let (module A) = Ast_builder.make loc in
@@ -121,16 +121,29 @@ let mutually_recursive_gens ~loc gens =
   let mutual_gens = A.pstr_value Recursive fake_gens in
   mutual_gens :: real_gens
 
+(** [tuple ~loc ?f tys] transforms list of type [tys] into a tuple generator.
+
+    [f] can be used to transform tuples, for instance:
+    {[
+    type t = Foo of int * int
+    ]}
 
-let map ~loc pat expr gen =
-  [%expr QCheck.Gen.map (fun [%p pat] -> [%e expr]) [%e gen]]
+    Without [f]:
+    {[
+    let gen = QCheck.Gen.(map (fun (x, y) -> (x, y)) (pair int int))
+    ]}
 
+    With [f], building Foo:
+    {[
+    let gen = QCheck.Gen.(map (fun (x, y) -> Foo (x, y)) (pair int int))
+    ]}
+*)
 let tuple ~loc ?(f = fun x -> x) tys =
   let tuple = Tuple.from_list tys in
   let gen = Tuple.to_gen ~loc tuple in
   let expr = Tuple.to_expr ~loc tuple |> f in
   let pat = Tuple.to_pat ~loc tuple in
-  map ~loc pat expr gen
+  G.map ~loc pat expr gen
 
 let record ~loc ~gens ?(f = fun x -> x) xs =
   let (module A) = Ast_builder.make loc in
@@ -152,26 +165,23 @@ let record ~loc ~gens ?(f = fun x -> x) xs =
   in
   let expr = A.pexp_record fields None |> f in
 
-  map ~loc pat expr gen
+  G.map ~loc pat expr gen
 
 let rec gen_from_type ~loc ?(env = TypeGen.empty) ?(typ_name = "") typ =
   Option.value (Attributes.gen typ)
     ~default:
       (match typ with
-      | [%type: unit] -> [%expr QCheck.Gen.unit]
-      | [%type: int] -> [%expr QCheck.Gen.int]
-      | [%type: string] | [%type: String.t] -> [%expr QCheck.Gen.string]
-      | [%type: char] -> [%expr QCheck.Gen.char]
-      | [%type: bool] -> [%expr QCheck.Gen.bool]
-      | [%type: float] -> [%expr QCheck.Gen.float]
-      | [%type: int32] | [%type: Int32.t] -> [%expr QCheck.Gen.int32]
-      | [%type: int64] | [%type: Int64.t] -> [%expr QCheck.Gen.int64]
-      | [%type: [%t? typ] option] ->
-          [%expr QCheck.Gen.option [%e gen_from_type ~loc ~env typ]]
-      | [%type: [%t? typ] list] ->
-          [%expr QCheck.Gen.list [%e gen_from_type ~loc ~env typ]]
-      | [%type: [%t? typ] array] ->
-          [%expr QCheck.Gen.array [%e gen_from_type ~loc ~env typ]]
+      | [%type: unit] -> G.unit loc
+      | [%type: int] -> G.int loc
+      | [%type: string] | [%type: String.t] -> G.string loc
+      | [%type: char] -> G.char loc
+      | [%type: bool] -> G.bool loc
+      | [%type: float] -> G.float loc
+      | [%type: int32] | [%type: Int32.t] -> G.int32 loc
+      | [%type: int64] | [%type: Int64.t] -> G.int64 loc
+      | [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc ~env typ)
+      | [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc ~env typ)
+      | [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc ~env typ)
       | { ptyp_desc = Ptyp_tuple typs; _ } ->
           let tys = List.map (gen_from_type ~loc ~env) typs in
           tuple ~loc tys
@@ -198,7 +208,7 @@ and gen_from_constr ~loc ?(env = TypeGen.empty)
   let gen =
     match pcd_args with
     | Pcstr_tuple [] | Pcstr_record [] ->
-        pure ~loc @@ A.econstruct constr_decl None
+        G.pure ~loc @@ A.econstruct constr_decl None
     | Pcstr_tuple xs ->
         let tys = List.map (gen_from_type ~loc ~env) xs in
         tuple ~loc ~f:mk_constr tys
@@ -223,7 +233,7 @@ and gen_from_variant ~loc typ_name rws =
     let gen =
       match row.prf_desc with
       | Rinherit typ -> gen_from_type ~loc typ
-      | Rtag (label, _, []) -> pure ~loc @@ A.pexp_variant label.txt None
+      | Rtag (label, _, []) -> G.pure ~loc @@ A.pexp_variant label.txt None
       | Rtag (label, _, typs) ->
           let f expr = A.pexp_variant label.txt (Some expr) in
           tuple ~loc ~f (List.map (gen_from_type ~loc ?env) typs)
@@ -246,25 +256,21 @@ 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_gen = A.Located.mk @@ Lident G.ty in
   let typ = A.ptyp_constr typ_gen [ typ_t ] in
   [%expr ([%e gen] : [%t typ])]
 
 and gen_from_arrow ~loc ~env left right =
   let rec observable = function
-    | [%type: unit] -> [%expr QCheck.Observable.unit]
-    | [%type: bool] -> [%expr QCheck.Observable.bool]
-    | [%type: int] -> [%expr QCheck.Observable.int]
-    | [%type: float] -> [%expr QCheck.Observable.float]
-    | [%type: string] -> [%expr QCheck.Observable.string]
-    | [%type: char] -> [%expr QCheck.Observable.char]
-    | [%type: [%t? typ] option] ->
-        [%expr QCheck.Observable.option [%e observable typ]]
-    | [%type: [%t? typ] array] ->
-        [%expr QCheck.Observable.array [%e observable typ]]
-    | [%type: [%t? typ] list] ->
-        [%expr QCheck.Observable.list [%e observable typ]]
+    | [%type: unit] -> O.unit loc
+    | [%type: bool] -> O.bool loc
+    | [%type: int] -> O.int loc
+    | [%type: float] -> O.float loc
+    | [%type: string] -> O.string loc
+    | [%type: char] -> O.char loc
+    | [%type: [%t? typ] option] -> O.option ~loc (observable typ)
+    | [%type: [%t? typ] array] -> O.array ~loc (observable typ)
+    | [%type: [%t? typ] list] -> O.list ~loc (observable typ)
     | { ptyp_desc = Ptyp_tuple xs; _ } ->
         let obs = List.map observable xs in
         Tuple.from_list obs |> Tuple.to_obs ~loc
@@ -280,6 +286,7 @@ and gen_from_arrow ~loc ~env left right =
     | x -> (gen_from_type ~loc ~env x, [%expr o_nil])
   in
   let x, obs = aux right in
+  (* TODO: export this in qcheck_generators for https://github.com/c-cube/qcheck/issues/190 *)
   let arb = [%expr QCheck.make [%e x]] in
   [%expr
     QCheck.fun_nary QCheck.Tuple.([%e observable left] @-> [%e obs]) [%e arb]
diff --git a/src/ppx_deriving_qcheck/qcheck_generators.ml b/src/ppx_deriving_qcheck/qcheck_generators.ml
new file mode 100644
index 00000000..54f397b9
--- /dev/null
+++ b/src/ppx_deriving_qcheck/qcheck_generators.ml
@@ -0,0 +1,92 @@
+open Ppxlib
+
+(** This module contains all generators from QCheck used to
+    derive a type declaration *)
+
+(** {2. Type} *)
+
+let ty = "QCheck.Gen.t"
+
+(** {2. Primitive generators} *)
+
+let unit loc = [%expr QCheck.Gen.unit]
+
+let int loc = [%expr QCheck.Gen.int]
+
+let string loc = [%expr QCheck.Gen.string]
+
+let char loc = [%expr QCheck.Gen.char]
+
+let bool loc = [%expr QCheck.Gen.bool]
+
+let float loc = [%expr QCheck.Gen.float]
+
+let int32 loc = [%expr QCheck.Gen.int32]
+
+let int64 loc = [%expr QCheck.Gen.int64]
+
+let option ~loc e = [%expr QCheck.Gen.option [%e e]]
+
+let list ~loc e = [%expr QCheck.Gen.list [%e e]]
+
+let array ~loc e = [%expr QCheck.Gen.array [%e e]]
+
+(** {2. Generator combinators} *)
+
+let pure ~loc x = [%expr QCheck.Gen.pure [%e x]] 
+
+let frequency ~loc l = [%expr QCheck.Gen.frequency [%e l]]
+
+let map ~loc pat expr gen =
+  [%expr QCheck.Gen.map (fun [%p pat] -> [%e expr]) [%e gen]]
+
+let pair ~loc a b =
+  [%expr QCheck.Gen.pair [%e a] [%e b]]
+
+let triple ~loc a b c =
+  [%expr QCheck.Gen.triple [%e a] [%e b] [%e c]]
+
+let quad ~loc a b c d=
+  [%expr QCheck.Gen.quad [%e a] [%e b] [%e c] [%e d]]
+
+let sized ~loc e =
+  [%expr QCheck.Gen.sized @@ [%e e]]
+
+let fix ~loc e =
+  [%expr QCheck.Gen.fix [%e e]]
+
+(** Observable generators *)
+module Observable = struct
+  (** {2. Primitive generators} *)
+  let unit loc = [%expr QCheck.Observable.unit]
+
+  let int loc = [%expr QCheck.Observable.int]
+
+  let string loc = [%expr QCheck.Observable.string]
+
+  let char loc = [%expr QCheck.Observable.char]
+
+  let bool loc = [%expr QCheck.Observable.bool]
+
+  let float loc = [%expr QCheck.Observable.float]
+
+  let int32 loc = [%expr QCheck.Observable.int32]
+
+  let int64 loc = [%expr QCheck.Observable.int64]
+
+  let option ~loc e = [%expr QCheck.Observable.option [%e e]]
+
+  let list ~loc e = [%expr QCheck.Observable.list [%e e]]
+
+  let array ~loc e = [%expr QCheck.Observable.array [%e e]]
+
+  (** {2. Observable combinators} *)
+  let pair ~loc a b =
+  [%expr QCheck.Observable.pair [%e a] [%e b]]
+
+  let triple ~loc a b c =
+    [%expr QCheck.Observable.triple [%e a] [%e b] [%e c]]
+
+  let quad ~loc a b c d=
+    [%expr QCheck.Observable.quad [%e a] [%e b] [%e c] [%e d]]
+end
diff --git a/src/ppx_deriving_qcheck/tuple.ml b/src/ppx_deriving_qcheck/tuple.ml
index 09dd3b0f..eac01bde 100644
--- a/src/ppx_deriving_qcheck/tuple.ml
+++ b/src/ppx_deriving_qcheck/tuple.ml
@@ -1,4 +1,6 @@
 open Ppxlib
+module G = Qcheck_generators
+module O = Qcheck_generators.Observable
 
 (** {1. Tuple } *)
 
@@ -86,29 +88,22 @@ let to_expr ~loc t =
     - [triple] to combine Triple (_, _, )
     - [quad] to combine Quad (_, _, _, _)
 *)
-let rec nest ~loc ~pair ~triple ~quad = function
-  | Quad (a, b, c, d) -> [%expr [%e quad] [%e a] [%e b] [%e c] [%e d]]
-  | Triple (a, b, c) -> [%expr [%e triple] [%e a] [%e b] [%e c]]
+let rec nest ~pair ~triple ~quad = function
+  | Quad (a, b, c, d) -> quad a b c d
+  | Triple (a, b, c) -> triple a b c
   | Pair (a, b) ->
-     [%expr
-         [%e pair]
-         [%e nest ~loc ~pair ~triple ~quad a]
-         [%e nest ~loc ~pair ~triple ~quad b]]
+     pair
+       (nest ~pair ~triple ~quad a)
+       (nest ~pair ~triple ~quad b)
   | Elem a -> a
 
 (** [to_gen t] creates a Gen.t with generators' combinators *)
 let to_gen ~loc t =
-  let pair = [%expr QCheck.Gen.pair] in
-  let triple = [%expr QCheck.Gen.triple] in
-  let quad = [%expr QCheck.Gen.quad] in
-  nest ~loc ~pair ~triple ~quad t
+  nest ~pair:(G.pair ~loc) ~triple:(G.triple ~loc) ~quad:(G.quad ~loc) t
 
 (** [to_obs t] creates a Obs.t with obsersvables' combinators *)
 let to_obs ~loc t =
-  let pair = [%expr QCheck.Observable.pair] in
-  let triple = [%expr QCheck.Observable.triple] in
-  let quad = [%expr QCheck.Observable.quad] in
-  nest ~loc ~pair ~triple ~quad t
+  nest ~pair:(O.pair ~loc) ~triple:(O.triple ~loc) ~quad:(O.quad ~loc) t
 
 let to_pat ~loc t =
   let fresh_id =

From b04ff2095dc16e8b730b02b60bf3998a5a2265b8 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Thu, 9 Dec 2021 11:50:01 +0100
Subject: [PATCH 03/10] Restructure main module with comments

---
 .../ppx_deriving_qcheck.ml                    | 131 ++++++++++++++----
 1 file changed, 105 insertions(+), 26 deletions(-)

diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index 5c690d41..511718a4 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -2,6 +2,23 @@ open Ppxlib
 module G = Qcheck_generators
 module O = G.Observable
 
+(** {1. ppx_deriving_qcheck} *)
+
+(** ppx_deriving_qcheck is a ppx deriver for QCheck generators. It does a traversal
+    map on type declarations annoted with [QCheck].
+
+    Example:
+    {[
+    module Tree : sig
+      type t
+
+      val gen : t QCheck.Gen.t
+    end = struct
+      type t = Leaf | Node of int * tree * tree
+      [@@deriving qcheck]
+    end
+    ]}
+*)
 
 (** TypeGen can serve as a derivation environment. The map can be used
     to remember how a type should be translated.
@@ -29,7 +46,7 @@ module O = G.Observable
                      ( 1,
                        map
                          (fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
-                         (triple int (self (n / 1)) (self (n / 1))) );])
+                         (triple int (self (n / 2)) (self (n / 2))) );])
     ]}
 
     The type [tree] is stored in a TypeGen.t with tree <- [%expr self (n/2)]. This
@@ -41,27 +58,67 @@ module TypeGen = Map.Make (struct
   let compare = compare
 end)
 
+(** {2. Misc. helpers} *)
+
 let rec longident_to_str = function
   | Lident s -> s
   | Ldot (lg, s) -> Printf.sprintf "%s.%s" (longident_to_str lg) s
   | Lapply (lg1, lg2) ->
       Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2)
 
+(** [is_rec_typ ty typ] looks for [ty] recursively in [typ].
+    It for now only finds in constr and tuples. *)
 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
 
+(** [name s] produces the generator name based on [s] *)
 let name s =
   let prefix = "gen" in
   match s with "t" -> prefix | s -> prefix ^ "_" ^ s
 
+(** [pat ~loc s] creates a pattern for a generator based on {!name}. *)
 let pat ~loc s =
   let (module A) = Ast_builder.make loc in
   let s = name s in
   A.pvar s
 
+let mutually_recursive_gens ~loc gens =
+  let (module A) = Ast_builder.make loc in
+  let fake_gens =
+    List.map
+      (function
+        | [%stri let [%p? pat] = [%e? expr]] ->
+            let expr = [%expr fun () -> [%e expr]] in
+            A.value_binding ~pat ~expr
+        | _ -> assert false)
+      gens
+  in
+  let real_gens =
+    List.map
+      (function
+        | [%stri
+            let [%p? { ppat_desc = Ppat_var { txt = s; _ }; _ } as pat] =
+              [%e? _expr]] ->
+            let expr = A.evar s in
+            [%stri let [%p pat] = [%e expr] ()]
+        | _ -> assert false)
+      gens
+  in
+
+  let mutual_gens = A.pstr_value Recursive fake_gens in
+  mutual_gens :: real_gens
+
+(** {2. Generator constructors} *)
+
+(** [gen lg] creates a generator using [lg].
+
+    The longident can either be a:
+    - Lident s: We transform to gen_s (or gen if s = "t")
+    - Ldot (lg, s): We transform to qualified generator (e.g. B.gen)
+*)
 let gen ~loc ?(env = TypeGen.empty) lg =
   let (module A) = Ast_builder.make loc in
   match lg with
@@ -70,6 +127,7 @@ let gen ~loc ?(env = TypeGen.empty) lg =
   | Ldot (lg, s) -> A.(pexp_ident (Located.mk @@ Ldot (lg, name s)))
   | Lapply (_, _) -> raise (Invalid_argument "gen received an Lapply")
 
+(** [tree nodes leaves] creates a tree like generator *)
 let tree ~loc nodes leaves =
   (G.sized ~loc) @@ (G.fix ~loc) @@
     [%expr
@@ -77,6 +135,27 @@ let tree ~loc nodes leaves =
         function
         | 0 -> [%e leaves] | n -> [%e nodes]]
 
+(** [sized typ_name is_rec to_gen xs] uses [is_rec] to determine recursive
+    nodes in [xs].
+
+    If no recursive node is found, the type is _not_ recursive, we build a
+    generator using frequency.
+
+    However, if recursive nodes are found, we build a tree like generator using
+    {!tree}.
+
+    The function is generalized for variants and polymorphic variants:
+
+    {[
+    type t = Leaf | Node of int * t * t
+
+    (* or *)
+
+    type t = [`Leaf | `Node of int * t * t]
+    ]}
+
+    Therefore, [is_rec] and [to_gen] are different for variants and polymorphic
+    variants. *)
 let sized ~loc ~env typ_name (is_rec : 'a -> bool)
     (to_gen : ?env:expression TypeGen.t -> 'a -> expression) (xs : 'a list) =
   let (module A) = Ast_builder.make loc in
@@ -95,31 +174,6 @@ let sized ~loc ~env typ_name (is_rec : 'a -> bool)
     let gens = A.elist leaves in
     G.frequency ~loc gens
 
-let mutually_recursive_gens ~loc gens =
-  let (module A) = Ast_builder.make loc in
-  let fake_gens =
-    List.map
-      (function
-        | [%stri let [%p? pat] = [%e? expr]] ->
-            let expr = [%expr fun () -> [%e expr]] in
-            A.value_binding ~pat ~expr
-        | _ -> assert false)
-      gens
-  in
-  let real_gens =
-    List.map
-      (function
-        | [%stri
-            let [%p? { ppat_desc = Ppat_var { txt = s; _ }; _ } as pat] =
-              [%e? _expr]] ->
-            let expr = A.evar s in
-            [%stri let [%p pat] = [%e expr] ()]
-        | _ -> assert false)
-      gens
-  in
-
-  let mutual_gens = A.pstr_value Recursive fake_gens in
-  mutual_gens :: real_gens
 
 (** [tuple ~loc ?f tys] transforms list of type [tys] into a tuple generator.
 
@@ -145,11 +199,31 @@ let tuple ~loc ?(f = fun x -> x) tys =
   let pat = Tuple.to_pat ~loc tuple in
   G.map ~loc pat expr gen
 
+(** [record loc gens ?f label_decls] transforms [gens] and [label_decls] to
+    a record generator.
+
+    Similarly to {!gen_tuple}, we can use [f] to transform records, for instance:
+    {[
+    type t = Foo of { left : int; right : int }
+    ]}
+
+    Without [f]:
+    {[
+    let gen = QCheck.Gen.(map (fun (x, y) -> {left = x; right = y}) (pair int int))
+    ]}
+
+    With [f], building Foo:
+    {[
+    let gen = QCheck.Gen.(map (fun (x, y) -> Foo {left = x; right = y}) (pair int int))
+    ]}
+
+*)
 let record ~loc ~gens ?(f = fun x -> x) xs =
   let (module A) = Ast_builder.make loc in
   let tuple = Tuple.from_list gens in
   let gen = Tuple.to_gen ~loc tuple in
   let pat = Tuple.to_pat ~loc tuple in
+  (* TODO: this should be handled in {!Tuple} *)
   let gens =
     List.mapi
       (fun i _ ->
@@ -167,6 +241,9 @@ let record ~loc ~gens ?(f = fun x -> x) xs =
 
   G.map ~loc pat expr gen
 
+(** {2. Core derivation} *)
+
+(** [gen_from_type typ] performs the AST traversal and derivation to qcheck generators *)
 let rec gen_from_type ~loc ?(env = TypeGen.empty) ?(typ_name = "") typ =
   Option.value (Attributes.gen typ)
     ~default:
@@ -348,6 +425,8 @@ let derive_gen ~loc xs : structure =
       let gens = List.map (gen_from_type_declaration ~loc ~env) xs in
       mutually_recursive_gens ~loc gens
 
+(** {2. Ppxlib machinery} *)
+
 let create_gen ~ctxt (decls : rec_flag * type_declaration list) : structure =
   let loc = Expansion_context.Deriver.derived_item_loc ctxt in
   derive_gen ~loc decls

From 03bc8420b6abcc0df1072c04a72f833dd75c781a Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Thu, 14 Oct 2021 12:01:53 +0200
Subject: [PATCH 04/10] Remove frequency when list contains one generator

---
 src/ppx_deriving_qcheck/README.md             |  4 +-
 .../ppx_deriving_qcheck.ml                    |  2 +-
 src/ppx_deriving_qcheck/qcheck_generators.ml  |  6 +-
 test/ppx_deriving_qcheck/deriver/test.ml      | 66 +++++--------------
 4 files changed, 23 insertions(+), 55 deletions(-)

diff --git a/src/ppx_deriving_qcheck/README.md b/src/ppx_deriving_qcheck/README.md
index 1f0ef796..0c47d30c 100644
--- a/src/ppx_deriving_qcheck/README.md
+++ b/src/ppx_deriving_qcheck/README.md
@@ -242,9 +242,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))]
+        | 0 -> QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int
         | n ->
           QCheck.Gen.frequency
             [(1,
diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index 511718a4..daf6cc52 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -38,7 +38,7 @@ module O = G.Observable
       let open Gen in
       sized
         @@ fix (fun self -> function
-             | 0 -> frequency [ (1, pure Leaf) ]
+             | 0 -> pure Leaf
              | n ->
                  frequency
                    [
diff --git a/src/ppx_deriving_qcheck/qcheck_generators.ml b/src/ppx_deriving_qcheck/qcheck_generators.ml
index 54f397b9..a104ce04 100644
--- a/src/ppx_deriving_qcheck/qcheck_generators.ml
+++ b/src/ppx_deriving_qcheck/qcheck_generators.ml
@@ -35,7 +35,11 @@ let array ~loc e = [%expr QCheck.Gen.array [%e e]]
 
 let pure ~loc x = [%expr QCheck.Gen.pure [%e x]] 
 
-let frequency ~loc l = [%expr QCheck.Gen.frequency [%e l]]
+let frequency ~loc l =
+  match l with
+  | [%expr [([%e? _], [%e? x])]] -> x
+  | _ ->
+     [%expr QCheck.Gen.frequency [%e l]]
 
 let map ~loc pat expr gen =
   [%expr QCheck.Gen.map (fun [%p pat] -> [%e expr]) [%e gen]]
diff --git a/test/ppx_deriving_qcheck/deriver/test.ml b/test/ppx_deriving_qcheck/deriver/test.ml
index 7d7d10b9..ef99801d 100644
--- a/test/ppx_deriving_qcheck/deriver/test.ml
+++ b/test/ppx_deriving_qcheck/deriver/test.ml
@@ -167,19 +167,12 @@ let test_alpha () =
     [
       [%stri let gen gen_a = gen_a];
       [%stri let gen gen_a = QCheck.Gen.list gen_a];
-      [%stri
-        let gen gen_a =
-          QCheck.Gen.frequency
-            [ (1, QCheck.Gen.map (fun gen0 -> A gen0) gen_a) ]];
+      [%stri let gen gen_a = QCheck.Gen.map (fun gen0 -> A gen0) gen_a];
       [%stri
         let gen gen_a gen_b =
-          QCheck.Gen.frequency
-            [
-              ( 1,
-                QCheck.Gen.map
-                  (fun (gen0, gen1) -> A (gen0, gen1))
-                  (QCheck.Gen.pair gen_a gen_b) );
-            ]];
+          QCheck.Gen.map
+            (fun (gen0, gen1) -> A (gen0, gen1))
+            (QCheck.Gen.pair gen_a gen_b)];
       [%stri
         let gen gen_left gen_right =
           QCheck.Gen.map
@@ -189,9 +182,7 @@ let test_alpha () =
         let gen_tree gen_a =
           QCheck.Gen.sized
           @@ QCheck.Gen.fix (fun self -> function
-               | 0 ->
-                   QCheck.Gen.frequency
-                     [ (1, QCheck.Gen.map (fun gen0 -> Leaf gen0) gen_a) ]
+               | 0 -> QCheck.Gen.map (fun gen0 -> Leaf gen0) gen_a
                | n ->
                    QCheck.Gen.frequency
                      [
@@ -278,10 +269,7 @@ let test_dependencies () =
 let test_konstr () =
   let expected =
     [
-      [%stri
-        let gen =
-          QCheck.Gen.frequency
-            [ (1, QCheck.Gen.map (fun gen0 -> A gen0) QCheck.Gen.int) ]];
+      [%stri let gen = QCheck.Gen.map (fun gen0 -> A gen0) QCheck.Gen.int];
       [%stri
         let gen =
           QCheck.Gen.frequency
@@ -433,7 +421,7 @@ let test_tree () =
         let gen_tree =
           QCheck.Gen.sized
           @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.frequency [ (1, QCheck.Gen.pure Leaf) ]
+               | 0 -> QCheck.Gen.pure Leaf
                | n ->
                    QCheck.Gen.frequency
                      [
@@ -450,13 +438,7 @@ let test_tree () =
         let gen_expr =
           QCheck.Gen.sized
           @@ QCheck.Gen.fix (fun self -> function
-               | 0 ->
-                   QCheck.Gen.frequency
-                     [
-                       ( 1,
-                         QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
-                       );
-                     ]
+               | 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
                | n ->
                    QCheck.Gen.frequency
                      [
@@ -503,13 +485,7 @@ let test_recursive () =
         let rec gen_expr () =
           QCheck.Gen.sized
           @@ QCheck.Gen.fix (fun self -> function
-               | 0 ->
-                   QCheck.Gen.frequency
-                     [
-                       ( 1,
-                         QCheck.Gen.map (fun gen0 -> Value gen0) (gen_value ())
-                       );
-                     ]
+               | 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) (gen_value ())
                | n ->
                    QCheck.Gen.frequency
                      [
@@ -563,20 +539,16 @@ let test_forest () =
     [
       [%stri
         let rec gen_tree () =
-          QCheck.Gen.frequency
-            [
-              ( 1,
-                QCheck.Gen.map
-                  (fun gen0 -> Node gen0)
-                  (QCheck.Gen.map
-                     (fun (gen0, gen1) -> (gen0, gen1))
-                     (QCheck.Gen.pair QCheck.Gen.int (gen_forest ()))) );
-            ]
+          QCheck.Gen.map
+            (fun gen0 -> Node gen0)
+            (QCheck.Gen.map
+               (fun (gen0, gen1) -> (gen0, gen1))
+               (QCheck.Gen.pair QCheck.Gen.int (gen_forest ())))
 
         and gen_forest () =
           QCheck.Gen.sized
           @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.frequency [ (1, QCheck.Gen.pure Nil) ]
+               | 0 -> QCheck.Gen.pure Nil
                | n ->
                    QCheck.Gen.frequency
                      [
@@ -800,13 +772,7 @@ let test_recursive_poly_variant () =
         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
-                        );
-                      ]
+                | 0 -> QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int
                 | n ->
                     QCheck.Gen.frequency
                       [

From 2352509bb655805ffe7863d08030618d69e4a618 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Thu, 9 Dec 2021 17:46:12 +0100
Subject: [PATCH 05/10] Refactor and improve design for recursive generators

---
 src/ppx_deriving_qcheck/README.md             |  25 +-
 src/ppx_deriving_qcheck/args.ml               |  24 ++
 .../ppx_deriving_qcheck.ml                    | 403 ++++++++++--------
 test/ppx_deriving_qcheck/deriver/test.ml      | 297 +++++--------
 4 files changed, 379 insertions(+), 370 deletions(-)
 create mode 100644 src/ppx_deriving_qcheck/args.ml

diff --git a/src/ppx_deriving_qcheck/README.md b/src/ppx_deriving_qcheck/README.md
index 0c47d30c..51ba6d73 100644
--- a/src/ppx_deriving_qcheck/README.md
+++ b/src/ppx_deriving_qcheck/README.md
@@ -238,18 +238,19 @@ let gen_color =
 type tree = Leaf of int | Node of tree * tree
 [@@deriving qcheck]
 
-let gen_tree =
-  QCheck.Gen.sized @@
-    (QCheck.Gen.fix
-      (fun self -> function
-        | 0 -> 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, gen1) -> Node (gen0, gen1))
-                 (QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))]))
+(* ==> *)
+
+let rec gen_tree_sized n =
+  match n with
+  | 0 -> 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, gen1) -> Node (gen0, gen1))
+             (QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))]))
+
+let gen_tree = QCheck.Gen.sized @@ gen_tree_sized
 ```
 
 * Recursive polymorphic variants
diff --git a/src/ppx_deriving_qcheck/args.ml b/src/ppx_deriving_qcheck/args.ml
new file mode 100644
index 00000000..084a8a14
--- /dev/null
+++ b/src/ppx_deriving_qcheck/args.ml
@@ -0,0 +1,24 @@
+open Ppxlib
+
+(** [curry_args args body] adds parameter to [body]
+
+    e.g.:
+    curry_args [gen_a; gen_b] () => fun gen_a -> fun gen_b -> ()
+*)
+let rec curry_args ~loc args body =
+  match args with
+  | [] -> body
+  | x :: xs -> [%expr fun [%p x] -> [%e curry_args ~loc xs body]]
+
+(** [apply_args args body] applies parameters to [body]
+
+    e.g.:
+    apply_args [gen_a; gen_b] f => f gen_a gen_b
+*)
+let apply_args ~loc args body =
+  let rec aux acc = function
+    | [] -> acc
+    | [arg] -> [%expr [%e acc] [%e arg]]
+    | arg :: args -> aux [%expr [%e acc] [%e arg]] args
+  in
+  aux body args
diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index daf6cc52..12d89cdd 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -14,51 +14,48 @@ module O = G.Observable
 
       val gen : t QCheck.Gen.t
     end = struct
-      type t = Leaf | Node of int * tree * tree
+      type t = Leaf | Node of int * t * t
       [@@deriving qcheck]
     end
     ]}
 *)
 
-(** TypeGen can serve as a derivation environment. The map can be used
-    to remember how a type should be translated.
+(** {2. Misc. helpers} *)
 
-    For instance, a recursive type must be derivated to a self recursive
-    call reducing the size.
+(** [name s] produces the generator name based on [s] *)
+let name ?(sized = false) s =
+  let prefix = "gen" in
+  (match s with "t" -> prefix | s -> prefix ^ "_" ^ s) ^
+    (if sized then "_sized" else "")
 
-    {[
-    type tree = Leaf of int | Node of tree * tree
-    ]}
+(** [pat ~loc s] creates a pattern for a generator based on {!name}. *)
+let pat ~loc ?sized s =
+  let (module A) = Ast_builder.make loc in
+  let s = name ?sized s in
+  A.pvar s
+
+(** {2. Recursive generators} *)
 
-    becomes
+(** Recursive generators must be treated separatly:
 
     {[
-    let gen_tree =
-      let open QCheck in
-      let open Gen in
-      sized
-        @@ fix (fun self -> function
-             | 0 -> pure Leaf
-             | n ->
-                 frequency
-                   [
-                     (1, pure Leaf);
-                     ( 1,
-                       map
-                         (fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
-                         (triple int (self (n / 2)) (self (n / 2))) );])
+    type 'a list = Cons of 'a * 'a list | Nil 
     ]}
 
-    The type [tree] is stored in a TypeGen.t with tree <- [%expr self (n/2)]. This
-    avoids the case where [tree] is derivated to [gen_tree]
-*)
-module TypeGen = Map.Make (struct
-  type t = string
+    becomes:
 
-  let compare = compare
-end)
+    {[
+    let rec gen_list_sized gen_a n =
+      match n with
+      | 0 -> pure Nil
+      | n -> map2 (fun x xs -> Cons (x, xs) gen_a (gen_list_sized gen_a (n/2))
 
-(** {2. Misc. helpers} *)
+    let gen_list_sized gen_a = sized @@ (gen_list_sized gen_a)
+    ]}
+
+    In the basic derivation {[ 'a list ]} would be translated to {[gen_list]}. However,
+    we want the generator to call itsef.
+ *)
 
 let rec longident_to_str = function
   | Lident s -> s
@@ -66,76 +63,92 @@ let rec longident_to_str = function
   | Lapply (lg1, lg2) ->
       Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2)
 
-(** [is_rec_typ ty typ] looks for [ty] recursively in [typ].
-    It for now only finds in constr and tuples. *)
-let rec is_rec_typ typ_name = function
+let rec is_rec_typ typ_names = 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
+     List.exists (fun typ_name -> longident_to_str x = typ_name) typ_names
+  | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ typ_names) xs
+  | { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
+     List.exists (fun rw ->
+         match rw.prf_desc with
+         | Rtag (lab, _, cts) ->
+            List.exists (fun typ_name -> lab.txt = typ_name) typ_names ||
+              List.exists (is_rec_typ typ_names) cts
+         | Rinherit ct -> is_rec_typ typ_names ct) rws
   | _ -> false
 
-(** [name s] produces the generator name based on [s] *)
-let name s =
-  let prefix = "gen" in
-  match s with "t" -> prefix | s -> prefix ^ "_" ^ s
-
-(** [pat ~loc s] creates a pattern for a generator based on {!name}. *)
-let pat ~loc s =
-  let (module A) = Ast_builder.make loc in
-  let s = name s in
-  A.pvar s
+let is_rec_constr_decl typ_names cd =
+  match cd.pcd_args with
+  | Pcstr_tuple cts -> List.exists (is_rec_typ typ_names) cts
+  | _ -> false
 
-let mutually_recursive_gens ~loc gens =
-  let (module A) = Ast_builder.make loc in
-  let fake_gens =
-    List.map
-      (function
-        | [%stri let [%p? pat] = [%e? expr]] ->
-            let expr = [%expr fun () -> [%e expr]] in
-            A.value_binding ~pat ~expr
-        | _ -> assert false)
-      gens
+(** [is_rec_type_decl typ_names typ] looks for elements of [typ_names]
+    recursively in [typ]. *)
+let is_rec_type_decl typ_names typ =
+  let in_type_kind =
+    match typ.ptype_kind with
+    | Ptype_variant cstrs -> List.exists (is_rec_constr_decl typ_names) cstrs
+    | _ -> false
   in
-  let real_gens =
-    List.map
-      (function
-        | [%stri
-            let [%p? { ppat_desc = Ppat_var { txt = s; _ }; _ } as pat] =
-              [%e? _expr]] ->
-            let expr = A.evar s in
-            [%stri let [%p pat] = [%e expr] ()]
-        | _ -> assert false)
-      gens
+  let in_manifest =
+    match typ.ptype_manifest with
+    | Some x -> is_rec_typ typ_names x
+    | None -> false
   in
+  in_type_kind || in_manifest
+
+(** [env] contains the list of recursive types during the derivation
+
+    i.e:
+    - contains one element maximum if its a single type declaration *)
+type env = string list ref
+
+(** [curr_types] saves both the current type and all mutual
+    recursive types *)
+let curr_types : (string * string list) option ref = ref None
+
+let set_curr_types x xs = curr_types := Some (x, xs)
+
+let clean_curr_types () = curr_types := None
+
+let curr_type () = Option.get !curr_types |> fst
+
+let curr_types () = Option.get !curr_types |> snd
+
+let env : env = ref []
+
+let clean_env () = env := []
+
+let is_rec x = List.mem x !env
+
+let add_env typ_names typ_name ty =
+  if is_rec_type_decl typ_names ty then
+    env := typ_name :: !env
 
-  let mutual_gens = A.pstr_value Recursive fake_gens in
-  mutual_gens :: real_gens
 
 (** {2. Generator constructors} *)
 
-(** [gen lg] creates a generator using [lg].
+(** [gen_longident lg args] creates a generator using [lg].
 
     The longident can either be a:
     - Lident s: We transform to gen_s (or gen if s = "t")
     - Ldot (lg, s): We transform to qualified generator (e.g. B.gen)
 *)
-let gen ~loc ?(env = TypeGen.empty) lg =
+let gen_longident ~loc lg args =
   let (module A) = Ast_builder.make loc in
   match lg with
   | Lident s ->
-      Option.value ~default:(name s |> A.evar) @@ TypeGen.find_opt s env
-  | Ldot (lg, s) -> A.(pexp_ident (Located.mk @@ Ldot (lg, name s)))
+     if is_rec s then
+       name ~sized:true s |> A.evar |>
+         Args.apply_args ~loc args |>
+         Args.apply_args ~loc [ [%expr (n / 2)] ]
+     else
+       name s |> A.evar |> Args.apply_args ~loc args
+  | Ldot (lg, s) ->
+     A.(pexp_ident (Located.mk @@ Ldot (lg, name s))) |>
+       Args.apply_args ~loc args
   | Lapply (_, _) -> raise (Invalid_argument "gen received an Lapply")
 
-(** [tree nodes leaves] creates a tree like generator *)
-let tree ~loc nodes leaves =
-  (G.sized ~loc) @@ (G.fix ~loc) @@
-    [%expr
-        fun self ->
-        function
-        | 0 -> [%e leaves] | n -> [%e nodes]]
-
-(** [sized typ_name is_rec to_gen xs] uses [is_rec] to determine recursive
+(** [gen_sized typ_name is_rec to_gen xs] uses [is_rec] to determine recursive
     nodes in [xs].
 
     If no recursive node is found, the type is _not_ recursive, we build a
@@ -156,26 +169,29 @@ let tree ~loc nodes leaves =
 
     Therefore, [is_rec] and [to_gen] are different for variants and polymorphic
     variants. *)
-let sized ~loc ~env typ_name (is_rec : 'a -> bool)
-    (to_gen : ?env:expression TypeGen.t -> 'a -> expression) (xs : 'a list) =
+let gen_sized ~loc (is_rec : 'a -> bool) (to_gen : 'a -> expression) (xs : 'a list) =
   let (module A) = Ast_builder.make loc in
-  let new_env = TypeGen.add typ_name [%expr self (n / 2)] env in
   let leaves =
-    List.filter (fun x -> not (is_rec x)) xs |> List.map (to_gen ~env)
+    List.filter (fun x -> not (is_rec x)) xs |> List.map to_gen
   in
   let nodes = List.filter is_rec xs in
 
-  if List.length nodes > 0 then
-    let nodes = List.map (to_gen ~env:new_env) nodes in
+  if List.length nodes = 0 then
+    G.frequency ~loc (A.elist leaves)
+  else if List.length leaves = 0 then
+    let nodes = List.map to_gen nodes in
+    G.frequency ~loc (A.elist nodes)
+  else
+    let nodes = List.map to_gen nodes in
     let leaves = A.elist leaves |> G.frequency ~loc
     and nodes = A.elist (leaves @ nodes) |> G.frequency ~loc in
-    tree ~loc nodes leaves
-  else
-    let gens = A.elist leaves in
-    G.frequency ~loc gens
-
+    [%expr
+        match n with
+        | 0 -> [%e leaves]
+        | n -> [%e nodes]
+    ]
 
-(** [tuple ~loc ?f tys] transforms list of type [tys] into a tuple generator.
+(** [gen_tuple ~loc ?f tys] transforms list of type [tys] into a tuple generator.
 
     [f] can be used to transform tuples, for instance:
     {[
@@ -192,14 +208,14 @@ let sized ~loc ~env typ_name (is_rec : 'a -> bool)
     let gen = QCheck.Gen.(map (fun (x, y) -> Foo (x, y)) (pair int int))
     ]}
 *)
-let tuple ~loc ?(f = fun x -> x) tys =
+let gen_tuple ~loc ?(f = fun x -> x) tys =
   let tuple = Tuple.from_list tys in
   let gen = Tuple.to_gen ~loc tuple in
   let expr = Tuple.to_expr ~loc tuple |> f in
   let pat = Tuple.to_pat ~loc tuple in
   G.map ~loc pat expr gen
 
-(** [record loc gens ?f label_decls] transforms [gens] and [label_decls] to
+(** [gen_record loc gens ?f label_decls] transforms [gens] and [label_decls] to
     a record generator.
 
     Similarly to {!gen_tuple}, we can use [f] to transform records, for instance:
@@ -218,7 +234,7 @@ let tuple ~loc ?(f = fun x -> x) tys =
     ]}
 
 *)
-let record ~loc ~gens ?(f = fun x -> x) xs =
+let gen_record ~loc ~gens ?(f = fun x -> x) xs =
   let (module A) = Ast_builder.make loc in
   let tuple = Tuple.from_list gens in
   let gen = Tuple.to_gen ~loc tuple in
@@ -244,7 +260,7 @@ let record ~loc ~gens ?(f = fun x -> x) xs =
 (** {2. Core derivation} *)
 
 (** [gen_from_type typ] performs the AST traversal and derivation to qcheck generators *)
-let rec gen_from_type ~loc ?(env = TypeGen.empty) ?(typ_name = "") typ =
+let rec gen_from_type ~loc typ =
   Option.value (Attributes.gen typ)
     ~default:
       (match typ with
@@ -256,26 +272,25 @@ let rec gen_from_type ~loc ?(env = TypeGen.empty) ?(typ_name = "") typ =
       | [%type: float] -> G.float loc
       | [%type: int32] | [%type: Int32.t] -> G.int32 loc
       | [%type: int64] | [%type: Int64.t] -> G.int64 loc
-      | [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc ~env typ)
-      | [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc ~env typ)
-      | [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc ~env typ)
+      | [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc typ)
+      | [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc typ)
+      | [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc typ)
       | { ptyp_desc = Ptyp_tuple typs; _ } ->
-          let tys = List.map (gen_from_type ~loc ~env) typs in
-          tuple ~loc tys
-      | { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, _); _ } ->
-          let x = TypeGen.find_opt (longident_to_str ty) env in
-          Option.value ~default:(gen ~loc ~env ty) x
-      | { ptyp_desc = Ptyp_var s; _ } -> gen ~loc (Lident s)
+          let tys = List.map (gen_from_type ~loc) typs in
+          gen_tuple ~loc tys
+      | { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, args); _ } ->
+         let args = List.map (gen_from_type ~loc) args in
+         gen_longident ~loc ty args
+      | { ptyp_desc = Ptyp_var s; _ } -> gen_longident ~loc (Lident s) []
       | { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
-          gen_from_variant ~loc typ_name rws
+          gen_from_variant ~loc rws
       | { ptyp_desc = Ptyp_arrow (_, left, right); _ } ->
-          gen_from_arrow ~loc ~env left right
+          gen_from_arrow ~loc  left right
       | _ ->
           Ppxlib.Location.raise_errorf ~loc
             "This type is not supported in ppx_deriving_qcheck")
 
-and gen_from_constr ~loc ?(env = TypeGen.empty)
-    { pcd_name; pcd_args; pcd_attributes; _ } =
+and gen_from_constr ~loc { pcd_name; pcd_args; pcd_attributes; _ } =
   let (module A) = Ast_builder.make loc in
   let constr_decl =
     A.constructor_declaration ~name:pcd_name ~args:pcd_args ~res:None
@@ -287,23 +302,23 @@ and gen_from_constr ~loc ?(env = TypeGen.empty)
     | Pcstr_tuple [] | Pcstr_record [] ->
         G.pure ~loc @@ A.econstruct constr_decl None
     | Pcstr_tuple xs ->
-        let tys = List.map (gen_from_type ~loc ~env) xs in
-        tuple ~loc ~f:mk_constr tys
+        let tys = List.map (gen_from_type ~loc ) xs in
+        gen_tuple ~loc ~f:mk_constr tys
     | Pcstr_record xs ->
-        let tys = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
-        record ~loc ~f:mk_constr ~gens:tys xs
+        let tys = List.map (fun x -> gen_from_type ~loc  x.pld_type) xs in
+        gen_record ~loc ~f:mk_constr ~gens:tys xs
   in
 
   A.pexp_tuple [ Option.value ~default:[%expr 1] weight; gen ]
 
-and gen_from_variant ~loc typ_name rws =
+and gen_from_variant ~loc rws =
   let (module A) = Ast_builder.make loc in
   let is_rec (row : row_field) : bool =
     match row.prf_desc with
     | Rinherit _ -> false
-    | Rtag (_, _, typs) -> List.exists (is_rec_typ typ_name) typs
+    | Rtag (_, _, typs) -> List.exists (is_rec_typ (curr_types ())) typs
   in
-  let to_gen ?env (row : row_field) : expression =
+  let to_gen (row : row_field) : expression =
     let w =
       Attributes.weight row.prf_attributes |> Option.value ~default:[%expr 1]
     in
@@ -313,31 +328,17 @@ and gen_from_variant ~loc typ_name rws =
       | Rtag (label, _, []) -> G.pure ~loc @@ A.pexp_variant label.txt None
       | Rtag (label, _, typs) ->
           let f expr = A.pexp_variant label.txt (Some expr) in
-          tuple ~loc ~f (List.map (gen_from_type ~loc ?env) typs)
+          gen_tuple ~loc ~f (List.map (gen_from_type ~loc) typs)
     in
     [%expr [%e w], [%e gen]]
   in
-  (* the environment is emptied, a variant can not be based on other mutuals types
-     containing variants
-
-     For instance, the following type is accepted:
-     {[
-       type x = [`X]
-       type xy = [`Y | foo]
-     ]}
-     However, this next is not:
-     {[
-       type xy = [`X | y]
-       and y = [`Y]
-     ]}
-  *)
-  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
+  let gen = gen_sized ~loc is_rec to_gen rws in
+  let typ_t = A.ptyp_constr (A.Located.mk @@ Lident (curr_type ())) [] in
   let typ_gen = A.Located.mk @@ Lident G.ty in
   let typ = A.ptyp_constr typ_gen [ typ_t ] in
   [%expr ([%e gen] : [%t typ])]
 
-and gen_from_arrow ~loc ~env left right =
+and gen_from_arrow ~loc left right =
   let rec observable = function
     | [%type: unit] -> O.unit loc
     | [%type: bool] -> O.bool loc
@@ -360,7 +361,7 @@ and gen_from_arrow ~loc ~env left right =
         let res, xs = aux xs in
         let obs = observable x in
         (res, [%expr [%e obs] @-> [%e xs]])
-    | x -> (gen_from_type ~loc ~env x, [%expr o_nil])
+    | x -> (gen_from_type ~loc  x, [%expr o_nil])
   in
   let x, obs = aux right in
   (* TODO: export this in qcheck_generators for https://github.com/c-cube/qcheck/issues/190 *)
@@ -369,61 +370,117 @@ and gen_from_arrow ~loc ~env left right =
     QCheck.fun_nary QCheck.Tuple.([%e observable left] @-> [%e obs]) [%e arb]
     |> QCheck.gen]
 
-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 =
-    match constr.pcd_args with
-    | Pcstr_tuple xs -> List.exists (is_rec_typ typ_name) xs
-    | _ -> false
-  in
-  sized ~loc ~env typ_name is_rec (gen_from_constr ~loc) xs
+(** [gen_from_type_declaration loc td] creates a generator from the type declaration.
+
+    It returns either `Recursive or `Normal.
 
-let rec curry_args ~loc args body =
-  match args with
-  | [] -> body
-  | x :: xs -> [%expr fun [%p x] -> [%e curry_args ~loc xs body]]
+    - `Normal of expression:
+    The derived generator is not recursive, we return only the generator.
 
-let gen_from_type_declaration ~loc ?(env = TypeGen.empty) td =
-  let name = td.ptype_name.txt in
-  let pat_gen = pat ~loc name in
+    - `Recursive of expression * expression
+    The derived generator was recursive (i.e. val gen : n -> t Gen.t), we return
+    the sized generator version, and a normal generator using this last with
+    [Gen.sized].
+*)
+let gen_from_type_declaration ~loc td =
+  let (module A) = Ast_builder.make loc in
+  let ty = curr_type () in
+  let is_rec = is_rec (curr_type ()) in
 
   let args =
     List.map
       (fun (typ, _) ->
-        match typ.ptyp_desc with Ptyp_var s -> pat ~loc s | _ -> assert false)
+        match typ.ptyp_desc with
+        | Ptyp_var s -> (pat ~loc s, name s |> A.evar)
+        | _ -> assert false)
       td.ptype_params
   in
+  let (args_pat, args_expr) = List.split args in
 
   let gen =
     match td.ptype_kind with
-    | Ptype_variant xs -> gen_from_kind_variant ~loc ~env name xs
+    | Ptype_variant xs ->
+       let is_rec cd = is_rec_constr_decl (curr_types ()) cd in
+       gen_sized ~loc is_rec (gen_from_constr ~loc) xs
     | Ptype_record xs ->
-        let gens = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
-        record ~loc ~gens xs
+        let gens = List.map (fun x -> gen_from_type ~loc  x.pld_type) xs in
+        gen_record ~loc ~gens xs
     | _ ->
         let typ = Option.get td.ptype_manifest in
-        gen_from_type ~loc ~env ~typ_name:name typ
+        gen_from_type ~loc  typ
+  in
+
+  let pat_gen = pat ~loc ty in
+  if not is_rec then
+    let gen = Args.curry_args ~loc args_pat gen in
+    `Normal [%stri let [%p pat_gen] = [%e gen]]
+  else
+    let gen = Args.curry_args ~loc (args_pat @ [A.pvar "n"]) gen in
+    let pat_gen_sized = pat ~loc ~sized:true ty in
+    let gen_sized = name ~sized:true ty |> A.evar in
+    let gen_normal =
+      Args.curry_args ~loc args_pat
+        (G.sized ~loc (Args.apply_args ~loc args_expr gen_sized))
+    in
+    `Recursive (
+        [%stri let rec [%p pat_gen_sized] = [%e gen]],
+        [%stri let [%p pat_gen] = [%e gen_normal]]
+      )
+
+(** *)
+let mutually_recursive_gens ~loc gens =
+  let (module A) = Ast_builder.make loc in
+  let to_mutualize_gens =
+    List.map (function
+        | `Recursive (x, _) -> x
+        | `Normal x -> x) gens
   in
-  let gen = curry_args ~loc args gen in
+  let normal_gens =
+    List.filter_map (function
+        | `Recursive (_, x) -> Some x
+        | `Normal _ -> None) gens
+  in
+  let gens =
+    List.map (function
+        | [%stri let [%p? pat] = [%e? expr]]
+          | [%stri let rec [%p? pat] = [%e? expr]] ->
+           A.value_binding ~pat ~expr
+        | _ -> assert false) to_mutualize_gens
+  in
+  let mutual_gens = A.pstr_value Recursive gens in
+  mutual_gens :: normal_gens
 
-  [%stri let [%p pat_gen] = [%e gen]]
+(** [derive_gen ~loc xs] creates generators for type declaration in [xs].
 
-let derive_gen ~loc xs : structure =
-  match xs with
-  | _, [ x ] -> [ gen_from_type_declaration ~loc x ]
+    It also has a hidden purpose: it sets the environment prior to
+    the derivation. It identifies recursive types declarations (e.g. list)
+    and its external arguments (e.g. 'a list).
+*)
+let derive_gen ~loc (xs : rec_flag * type_declaration list) : structure =
+  (match xs with
+  | (_, [ x ]) ->
+     let () = set_curr_types x.ptype_name.txt [x.ptype_name.txt] in
+     let () = add_env [x.ptype_name.txt] x.ptype_name.txt x in
+     (match gen_from_type_declaration ~loc x with
+     | `Recursive (gen_sized, gen) -> [gen_sized; gen]
+     | `Normal gen -> [gen])
   | _, xs ->
-      let (module A) = Ast_builder.make loc in
-      let env =
-        List.fold_left
-          (fun env td ->
-            let x = td.ptype_name.txt in
-            let gen = name x |> A.evar in
-            let expr = [%expr [%e gen] ()] in
-            TypeGen.add x expr env)
-          TypeGen.empty xs
-      in
-      let gens = List.map (gen_from_type_declaration ~loc ~env) xs in
-      mutually_recursive_gens ~loc gens
+     let typ_names = List.map (fun x -> x.ptype_name.txt) xs in
+     let () =
+       List.map (fun x -> (x.ptype_name.txt, x)) xs |>
+         List.iter (fun (x, y) -> add_env typ_names x y)
+     in
+     let gens =
+       List.map (fun x ->
+           let () = set_curr_types x.ptype_name.txt typ_names in
+           gen_from_type_declaration ~loc x) xs
+     in
+     mutually_recursive_gens ~loc gens)
+  |>
+    fun res ->
+    let () = clean_env () in
+    let () = clean_curr_types () in
+    res
 
 (** {2. Ppxlib machinery} *)
 
diff --git a/test/ppx_deriving_qcheck/deriver/test.ml b/test/ppx_deriving_qcheck/deriver/test.ml
index ef99801d..515d47c5 100644
--- a/test/ppx_deriving_qcheck/deriver/test.ml
+++ b/test/ppx_deriving_qcheck/deriver/test.ml
@@ -179,19 +179,8 @@ let test_alpha () =
             (fun (gen0, gen1) -> (gen0, gen1))
             (QCheck.Gen.pair gen_left gen_right)];
       [%stri
-        let gen_tree gen_a =
-          QCheck.Gen.sized
-          @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.map (fun gen0 -> Leaf gen0) gen_a
-               | n ->
-                   QCheck.Gen.frequency
-                     [
-                       (1, QCheck.Gen.map (fun gen0 -> Leaf gen0) gen_a);
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1) -> Node (gen0, gen1))
-                           (QCheck.Gen.pair (self (n / 2)) (self (n / 2))) );
-                     ])];
+       let gen_int_tree = gen_tree QCheck.Gen.int
+      ]
     ]
   in
   let actual =
@@ -203,7 +192,7 @@ let test_alpha () =
            [%stri type 'a t = A of 'a];
            [%stri type ('a, 'b) t = A of 'a * 'b];
            [%stri type ('left, 'right) t = 'left * 'right];
-           [%stri type 'a tree = Leaf of 'a | Node of 'a tree * 'a tree];
+           [%stri type int_tree = int tree]
          ]
   in
   check_eq ~expected ~actual "deriving alpha"
@@ -373,30 +362,6 @@ let test_variant () =
                (1, QCheck.Gen.map (fun gen0 -> `C gen0) QCheck.Gen.string);
              ]
             : t QCheck.Gen.t)];
-      [%stri
-        let gen =
-          (QCheck.Gen.sized
-           @@ QCheck.Gen.fix (fun self -> function
-                | 0 ->
-                    QCheck.Gen.frequency
-                      [
-                        (1, QCheck.Gen.pure `A);
-                        (1, QCheck.Gen.map (fun gen0 -> `B gen0) QCheck.Gen.int);
-                        ( 1,
-                          QCheck.Gen.map (fun gen0 -> `C gen0) QCheck.Gen.string
-                        );
-                      ]
-                | n ->
-                    QCheck.Gen.frequency
-                      [
-                        (1, QCheck.Gen.pure `A);
-                        (1, QCheck.Gen.map (fun gen0 -> `B gen0) QCheck.Gen.int);
-                        ( 1,
-                          QCheck.Gen.map (fun gen0 -> `C gen0) QCheck.Gen.string
-                        );
-                        (1, QCheck.Gen.map (fun gen0 -> `D gen0) (self (n / 2)));
-                      ])
-            : t QCheck.Gen.t)];
       [%stri
         let gen_t' =
           (QCheck.Gen.frequency [ (1, QCheck.Gen.pure `B); (1, gen) ]
@@ -408,7 +373,6 @@ let test_variant () =
     @@ extract'
          [
            [%stri type t = [ `A | `B of int | `C of string ]];
-           [%stri type t = [ `A | `B of int | `C of string | `D of t ]];
            [%stri type t' = [ `B | t ]];
          ]
   in
@@ -418,159 +382,118 @@ let test_tree () =
   let expected =
     [
       [%stri
-        let gen_tree =
-          QCheck.Gen.sized
-          @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.pure Leaf
-               | n ->
-                   QCheck.Gen.frequency
-                     [
-                       (1, QCheck.Gen.pure Leaf);
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
-                           (QCheck.Gen.triple
-                              QCheck.Gen.int
-                              (self (n / 2))
-                              (self (n / 2))) );
-                     ])];
-      [%stri
-        let gen_expr =
-          QCheck.Gen.sized
-          @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
-               | n ->
-                   QCheck.Gen.frequency
-                     [
-                       ( 1,
-                         QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
-                       );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1, gen2) -> If (gen0, gen1, gen2))
-                           (QCheck.Gen.triple
-                              (self (n / 2))
-                              (self (n / 2))
-                              (self (n / 2))) );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1) -> Eq (gen0, gen1))
-                           (QCheck.Gen.pair (self (n / 2)) (self (n / 2))) );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1) -> Lt (gen0, gen1))
-                           (QCheck.Gen.pair (self (n / 2)) (self (n / 2))) );
-                     ])];
+       let rec gen_tree_sized gen_a n =
+         match n with
+         | 0 -> QCheck.Gen.pure Leaf
+         | n ->
+            QCheck.Gen.frequency
+              [
+                (1, QCheck.Gen.pure Leaf);
+                ( 1,
+                  QCheck.Gen.map
+                    (fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
+                    (QCheck.Gen.triple
+                       gen_a
+                       ((gen_tree_sized gen_a) (n / 2))
+                       ((gen_tree_sized gen_a) (n / 2))) );
+              ]
+      ];
+      [%stri
+       let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)
+      ];
     ]
   in
   let actual =
-    f'
-    @@ extract'
-         [
-           [%stri type tree = Leaf | Node of int * tree * tree];
-           [%stri
-             type expr =
-               | Value of int
-               | If of expr * expr * expr
-               | Eq of expr * expr
-               | Lt of expr * expr];
-         ]
+    f
+    @@ extract [%stri type 'a tree = Leaf | Node of 'a * 'a tree * 'a tree];
   in
   check_eq ~expected ~actual "deriving tree"
 
-let test_recursive () =
+let test_expr () =
   let expected =
     [
       [%stri
-        let rec gen_expr () =
-          QCheck.Gen.sized
-          @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) (gen_value ())
-               | n ->
-                   QCheck.Gen.frequency
-                     [
-                       ( 1,
-                         QCheck.Gen.map (fun gen0 -> Value gen0) (gen_value ())
-                       );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1, gen2) -> If (gen0, gen1, gen2))
-                           (QCheck.Gen.triple
-                              (self (n / 2))
-                              (self (n / 2))
-                              (self (n / 2))) );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1) -> Eq (gen0, gen1))
-                           (QCheck.Gen.pair (self (n / 2)) (self (n / 2))) );
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun (gen0, gen1) -> Lt (gen0, gen1))
-                           (QCheck.Gen.pair (self (n / 2)) (self (n / 2))) );
-                     ])
-
-        and gen_value () =
-          QCheck.Gen.frequency
-            [
-              (1, QCheck.Gen.map (fun gen0 -> Bool gen0) QCheck.Gen.bool);
-              (1, QCheck.Gen.map (fun gen0 -> Int gen0) QCheck.Gen.int);
-            ]];
-      [%stri let gen_expr = gen_expr ()];
-      [%stri let gen_value = gen_value ()];
+       let rec gen_expr_sized n =
+         match n with
+         | 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
+         | n ->
+            QCheck.Gen.frequency
+              [
+                ( 1,
+                  QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
+                );
+                ( 1,
+                  QCheck.Gen.map
+                    (fun (gen0, gen1, gen2) -> If (gen0, gen1, gen2))
+                    (QCheck.Gen.triple
+                       (gen_expr_sized (n / 2))
+                       (gen_expr_sized (n / 2))
+                       (gen_expr_sized (n / 2))) );
+                ( 1,
+                  QCheck.Gen.map
+                    (fun (gen0, gen1) -> Eq (gen0, gen1))
+                    (QCheck.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
+                ( 1,
+                  QCheck.Gen.map
+                    (fun (gen0, gen1) -> Lt (gen0, gen1))
+                    (QCheck.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
+              ]
+      ];
+      [%stri
+       let gen_expr = QCheck.Gen.sized @@ gen_expr_sized
+      ]
     ]
   in
-
   let actual =
-    f
-    @@ extract
-         [%stri
-           type expr =
-             | Value of value
-             | If of expr * expr * expr
-             | Eq of expr * expr
-             | Lt of expr * expr
-
-           and value = Bool of bool | Int of int]
-  in
-  check_eq ~expected ~actual "deriving recursive"
-
+    f @@ extract
+           [%stri
+            type expr =
+              | Value of int
+              | If of expr * expr * expr
+              | Eq of expr * expr
+              | Lt of expr * expr]
+  in
+  check_eq ~expected ~actual "deriving expr"
+  
 let test_forest () =
   let expected =
     [
       [%stri
-        let rec gen_tree () =
+        let rec gen_tree_sized gen_a n =
           QCheck.Gen.map
             (fun gen0 -> Node gen0)
             (QCheck.Gen.map
                (fun (gen0, gen1) -> (gen0, gen1))
-               (QCheck.Gen.pair QCheck.Gen.int (gen_forest ())))
-
-        and gen_forest () =
-          QCheck.Gen.sized
-          @@ QCheck.Gen.fix (fun self -> function
-               | 0 -> QCheck.Gen.pure Nil
-               | n ->
-                   QCheck.Gen.frequency
-                     [
-                       (1, QCheck.Gen.pure Nil);
-                       ( 1,
-                         QCheck.Gen.map
-                           (fun gen0 -> Cons gen0)
-                           (QCheck.Gen.map
-                              (fun (gen0, gen1) -> (gen0, gen1))
-                              (QCheck.Gen.pair (gen_tree ()) (self (n / 2)))) );
-                     ])];
-      [%stri let gen_tree = gen_tree ()];
-      [%stri let gen_forest = gen_forest ()];
+               (QCheck.Gen.pair gen_a ((gen_forest_sized gen_a) (n / 2))))
+
+        and gen_forest_sized gen_a n =
+          match n with
+          | 0 -> QCheck.Gen.pure Nil
+          | n ->
+             QCheck.Gen.frequency
+               [
+                 (1, QCheck.Gen.pure Nil);
+                 ( 1,
+                   QCheck.Gen.map
+                     (fun gen0 -> Cons gen0)
+                     (QCheck.Gen.map
+                        (fun (gen0, gen1) -> (gen0, gen1))
+                        (QCheck.Gen.pair
+                           ((gen_tree_sized gen_a) (n / 2))
+                           ((gen_forest_sized gen_a) (n / 2)))) );
+               ]
+      ];
+      [%stri let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)];
+      [%stri let gen_forest gen_a = QCheck.Gen.sized @@ (gen_forest_sized gen_a)];
     ]
   in
   let actual =
     f
     @@ extract
          [%stri
-           type tree = Node of (int * forest)
+           type 'a tree = Node of ('a * 'a forest)
 
-           and forest = Nil | Cons of (tree * forest)]
+           and 'a forest = Nil | Cons of ('a tree * 'a forest)]
   in
   check_eq ~expected ~actual "deriving forest"
 
@@ -769,29 +692,33 @@ let test_recursive_poly_variant () =
   let expected =
     [
       [%stri
-        let gen_tree =
-          (QCheck.Gen.sized
-           @@ QCheck.Gen.fix (fun self -> function
-                | 0 -> 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))))
-                        );
-                      ])
+       let rec gen_tree_sized gen_a n =
+         (match n with
+         | 0 -> QCheck.Gen.map (fun gen0 -> `Leaf gen0) gen_a
+         | n ->
+            QCheck.Gen.frequency
+              [
+                ( 1,
+                  QCheck.Gen.map (fun gen0 -> `Leaf gen0) gen_a
+                );
+                ( 1,
+                  QCheck.Gen.map
+                    (fun gen0 -> `Node gen0)
+                    (QCheck.Gen.map
+                       (fun (gen0, gen1) -> (gen0, gen1))
+                       (QCheck.Gen.pair
+                          ((gen_tree_sized gen_a) (n / 2))
+                          ((gen_tree_sized gen_a) (n / 2))))
+                );
+              ]
             : tree QCheck.Gen.t)];
+      [%stri
+       let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)
+      ]
     ]
   in
   let actual =
-    f @@ extract [%stri type tree = [ `Leaf of int | `Node of tree * tree ]]
+    f @@ extract [%stri type 'a tree = [ `Leaf of 'a | `Node of 'a tree * 'a tree ]]
   in
   check_eq ~expected ~actual "deriving recursive polymorphic variants"
 
@@ -822,10 +749,10 @@ let () =
             test_case "deriving record" `Quick test_record;
             test_case "deriving equal" `Quick test_equal;
             test_case "deriving tree like" `Quick test_tree;
+            test_case "deriving expr like" `Quick test_expr;
             test_case "deriving alpha" `Quick test_alpha;
             test_case "deriving variant" `Quick test_variant;
             test_case "deriving weight constructors" `Quick test_weight_konstrs;
-            test_case "deriving recursive" `Quick test_recursive;
             test_case "deriving forest" `Quick test_forest;
             test_case "deriving fun primitives" `Quick test_fun_primitives;
             test_case "deriving fun option" `Quick test_fun_option;

From 37c22b481d033193d720c35ee4644c5c7a7e8d68 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Fri, 10 Dec 2021 11:59:33 +0100
Subject: [PATCH 06/10] Clarify sized generators and generators names in README

---
 src/ppx_deriving_qcheck/README.md              | 10 ++++++++++
 src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml |  2 +-
 2 files changed, 11 insertions(+), 1 deletion(-)

diff --git a/src/ppx_deriving_qcheck/README.md b/src/ppx_deriving_qcheck/README.md
index 51ba6d73..333c90fe 100644
--- a/src/ppx_deriving_qcheck/README.md
+++ b/src/ppx_deriving_qcheck/README.md
@@ -18,6 +18,16 @@ let test =
 	(fun tree -> rev (rev tree) = tree)
 ```
 
+For `type tree` we derive two generators:
+- `val gen_tree : tree Gen.t` and
+- `val gen_tree_sized : int -> tree Gen.t`
+
+For non-recursive types the latter is however not derived.
+
+For types with the name `t` (i.e. `type t = ...`) which is a common idiom in OCaml code,
+the deriver omits the name from the derived generators,
+thus producing `val gen : t Gen.t` and optionally `val gen_sized : int -> t Gen.t`.
+
 ### Overwrite generator
 If you wan't to specify your own `generator` for any type you can
 add an attribute to the type:
diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index 12d89cdd..a2fea633 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -155,7 +155,7 @@ let gen_longident ~loc lg args =
     generator using frequency.
 
     However, if recursive nodes are found, we build a tree like generator using
-    {!tree}.
+    {!gen_sized}.
 
     The function is generalized for variants and polymorphic variants:
 

From 961928730fe3e78b8d88a34807690defd656482a Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Fri, 10 Dec 2021 14:19:56 +0100
Subject: [PATCH 07/10] Use environement variable instead of impure ref

---
 .../ppx_deriving_qcheck.ml                    | 193 ++++++++----------
 1 file changed, 87 insertions(+), 106 deletions(-)

diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index a2fea633..f9ccbc24 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -4,8 +4,8 @@ module O = G.Observable
 
 (** {1. ppx_deriving_qcheck} *)
 
-(** ppx_deriving_qcheck is a ppx deriver for QCheck generators. It does a traversal
-    map on type declarations annoted with [QCheck].
+(** ppx_deriving_qcheck is a ppx deriver for QCheck generators. It does a
+    traversal map on type declarations annoted with [QCheck].
 
     Example:
     {[
@@ -39,7 +39,7 @@ let pat ~loc ?sized s =
 (** Recursive generators must be treated separatly:
 
     {[
-    type 'a list = Cons of 'a * 'a list | Nil 
+    type 'a list = Cons of 'a * 'a list | Nil
     ]}
 
     becomes:
@@ -53,78 +53,65 @@ let pat ~loc ?sized s =
     let gen_list_sized gen_a = sized @@ (gen_list_sized gen_a)
     ]}
 
-    In the basic derivation {[ 'a list ]} would be translated to {[gen_list]}. However,
-    we want the generator to call itsef.
+    In the basic derivation {[ 'a list ]} would be translated to {[gen_list]}.
+    However, we want the generator to call itsef.
  *)
 
+module Env = struct
+  (** [env] contains:
+      - the list of recursive types during the derivation
+      - the list of types to derive (i.e. mutual types)
+      - the current type to derive *)
+  type env = {
+      rec_types : string list;
+      curr_types : string list;
+      curr_type : string;
+    }
+
+  let is_rec env x = List.mem x env.rec_types
+end
+
 let rec longident_to_str = function
   | Lident s -> s
   | Ldot (lg, s) -> Printf.sprintf "%s.%s" (longident_to_str lg) s
   | Lapply (lg1, lg2) ->
       Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2)
 
-let rec is_rec_typ typ_names = function
+let rec is_rec_typ env = function
   | { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } ->
-     List.exists (fun typ_name -> longident_to_str x = typ_name) typ_names
-  | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ typ_names) xs
+     List.exists (fun typ_name -> longident_to_str x = typ_name) env.Env.curr_types
+  | { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ env) xs
   | { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
-     List.exists (fun rw ->
-         match rw.prf_desc with
-         | Rtag (lab, _, cts) ->
-            List.exists (fun typ_name -> lab.txt = typ_name) typ_names ||
-              List.exists (is_rec_typ typ_names) cts
-         | Rinherit ct -> is_rec_typ typ_names ct) rws
+     List.exists (is_rec_row_field env) rws
   | _ -> false
 
-let is_rec_constr_decl typ_names cd =
+and is_rec_row_field env rw =
+  match rw.prf_desc with
+  | Rtag (lab, _, cts) ->
+     List.exists (fun typ_name -> lab.txt = typ_name) env.Env.curr_types ||
+       List.exists (is_rec_typ env) cts
+  | Rinherit ct -> is_rec_typ env ct
+
+let is_rec_constr_decl env cd =
   match cd.pcd_args with
-  | Pcstr_tuple cts -> List.exists (is_rec_typ typ_names) cts
+  | Pcstr_tuple cts -> List.exists (is_rec_typ env) cts
   | _ -> false
 
-(** [is_rec_type_decl typ_names typ] looks for elements of [typ_names]
+(** [is_rec_type_decl env typ] looks for elements of [env.curr_types]
     recursively in [typ]. *)
-let is_rec_type_decl typ_names typ =
+let is_rec_type_decl env typ =
   let in_type_kind =
     match typ.ptype_kind with
-    | Ptype_variant cstrs -> List.exists (is_rec_constr_decl typ_names) cstrs
+    | Ptype_variant cstrs -> List.exists (is_rec_constr_decl env) cstrs
     | _ -> false
   in
   let in_manifest =
     match typ.ptype_manifest with
-    | Some x -> is_rec_typ typ_names x
+    | Some x -> is_rec_typ env x
     | None -> false
   in
   in_type_kind || in_manifest
 
-(** [env] contains the list of recursive types during the derivation
-
-    i.e:
-    - contains one element maximum if its a single type declaration *)
-type env = string list ref
-
-(** [curr_types] saves both the current type and all mutual
-    recursive types *)
-let curr_types : (string * string list) option ref = ref None
-
-let set_curr_types x xs = curr_types := Some (x, xs)
-
-let clean_curr_types () = curr_types := None
-
-let curr_type () = Option.get !curr_types |> fst
-
-let curr_types () = Option.get !curr_types |> snd
-
-let env : env = ref []
-
-let clean_env () = env := []
-
-let is_rec x = List.mem x !env
-
-let add_env typ_names typ_name ty =
-  if is_rec_type_decl typ_names ty then
-    env := typ_name :: !env
-
-
 (** {2. Generator constructors} *)
 
 (** [gen_longident lg args] creates a generator using [lg].
@@ -133,11 +120,11 @@ let add_env typ_names typ_name ty =
     - Lident s: We transform to gen_s (or gen if s = "t")
     - Ldot (lg, s): We transform to qualified generator (e.g. B.gen)
 *)
-let gen_longident ~loc lg args =
+let gen_longident ~loc ~env lg args =
   let (module A) = Ast_builder.make loc in
   match lg with
   | Lident s ->
-     if is_rec s then
+     if Env.is_rec env s then
        name ~sized:true s |> A.evar |>
          Args.apply_args ~loc args |>
          Args.apply_args ~loc [ [%expr (n / 2)] ]
@@ -260,7 +247,7 @@ let gen_record ~loc ~gens ?(f = fun x -> x) xs =
 (** {2. Core derivation} *)
 
 (** [gen_from_type typ] performs the AST traversal and derivation to qcheck generators *)
-let rec gen_from_type ~loc typ =
+let rec gen_from_type ~loc ~env typ =
   Option.value (Attributes.gen typ)
     ~default:
       (match typ with
@@ -272,25 +259,25 @@ let rec gen_from_type ~loc typ =
       | [%type: float] -> G.float loc
       | [%type: int32] | [%type: Int32.t] -> G.int32 loc
       | [%type: int64] | [%type: Int64.t] -> G.int64 loc
-      | [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc typ)
-      | [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc typ)
-      | [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc typ)
+      | [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc ~env typ)
+      | [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc ~env typ)
+      | [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc ~env typ)
       | { ptyp_desc = Ptyp_tuple typs; _ } ->
-          let tys = List.map (gen_from_type ~loc) typs in
+          let tys = List.map (gen_from_type ~loc ~env) typs in
           gen_tuple ~loc tys
       | { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, args); _ } ->
-         let args = List.map (gen_from_type ~loc) args in
-         gen_longident ~loc ty args
-      | { ptyp_desc = Ptyp_var s; _ } -> gen_longident ~loc (Lident s) []
+         let args = List.map (gen_from_type ~loc ~env) args in
+         gen_longident ~loc ~env ty args
+      | { ptyp_desc = Ptyp_var s; _ } -> gen_longident ~loc ~env (Lident s) []
       | { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
-          gen_from_variant ~loc rws
+          gen_from_variant ~loc ~env rws
       | { ptyp_desc = Ptyp_arrow (_, left, right); _ } ->
-          gen_from_arrow ~loc  left right
+          gen_from_arrow ~loc ~env left right
       | _ ->
           Ppxlib.Location.raise_errorf ~loc
             "This type is not supported in ppx_deriving_qcheck")
 
-and gen_from_constr ~loc { pcd_name; pcd_args; pcd_attributes; _ } =
+and gen_from_constr ~loc ~env { pcd_name; pcd_args; pcd_attributes; _ } =
   let (module A) = Ast_builder.make loc in
   let constr_decl =
     A.constructor_declaration ~name:pcd_name ~args:pcd_args ~res:None
@@ -302,43 +289,39 @@ and gen_from_constr ~loc { pcd_name; pcd_args; pcd_attributes; _ } =
     | Pcstr_tuple [] | Pcstr_record [] ->
         G.pure ~loc @@ A.econstruct constr_decl None
     | Pcstr_tuple xs ->
-        let tys = List.map (gen_from_type ~loc ) xs in
+        let tys = List.map (gen_from_type ~loc ~env) xs in
         gen_tuple ~loc ~f:mk_constr tys
     | Pcstr_record xs ->
-        let tys = List.map (fun x -> gen_from_type ~loc  x.pld_type) xs in
+        let tys = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
         gen_record ~loc ~f:mk_constr ~gens:tys xs
   in
 
   A.pexp_tuple [ Option.value ~default:[%expr 1] weight; gen ]
 
-and gen_from_variant ~loc rws =
+and gen_from_variant ~loc ~env rws =
   let (module A) = Ast_builder.make loc in
-  let is_rec (row : row_field) : bool =
-    match row.prf_desc with
-    | Rinherit _ -> false
-    | Rtag (_, _, typs) -> List.exists (is_rec_typ (curr_types ())) typs
-  in
+  let is_rec = is_rec_row_field env in
   let to_gen (row : row_field) : expression =
     let w =
       Attributes.weight row.prf_attributes |> Option.value ~default:[%expr 1]
     in
     let gen =
       match row.prf_desc with
-      | Rinherit typ -> gen_from_type ~loc typ
+      | Rinherit typ -> gen_from_type ~loc ~env typ
       | Rtag (label, _, []) -> G.pure ~loc @@ A.pexp_variant label.txt None
       | Rtag (label, _, typs) ->
           let f expr = A.pexp_variant label.txt (Some expr) in
-          gen_tuple ~loc ~f (List.map (gen_from_type ~loc) typs)
+          gen_tuple ~loc ~f (List.map (gen_from_type ~loc ~env) typs)
     in
     [%expr [%e w], [%e gen]]
   in
   let gen = gen_sized ~loc is_rec to_gen rws in
-  let typ_t = A.ptyp_constr (A.Located.mk @@ Lident (curr_type ())) [] 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 = A.ptyp_constr typ_gen [ typ_t ] in
   [%expr ([%e gen] : [%t typ])]
 
-and gen_from_arrow ~loc left right =
+and gen_from_arrow ~loc ~env left right =
   let rec observable = function
     | [%type: unit] -> O.unit loc
     | [%type: bool] -> O.bool loc
@@ -361,7 +344,7 @@ and gen_from_arrow ~loc left right =
         let res, xs = aux xs in
         let obs = observable x in
         (res, [%expr [%e obs] @-> [%e xs]])
-    | x -> (gen_from_type ~loc  x, [%expr o_nil])
+    | x -> (gen_from_type ~loc ~env x, [%expr o_nil])
   in
   let x, obs = aux right in
   (* TODO: export this in qcheck_generators for https://github.com/c-cube/qcheck/issues/190 *)
@@ -382,10 +365,10 @@ and gen_from_arrow ~loc left right =
     the sized generator version, and a normal generator using this last with
     [Gen.sized].
 *)
-let gen_from_type_declaration ~loc td =
+let gen_from_type_declaration ~loc ~env td =
   let (module A) = Ast_builder.make loc in
-  let ty = curr_type () in
-  let is_rec = is_rec (curr_type ()) in
+  let ty = env.Env.curr_type in
+  let is_rec = Env.is_rec env ty in
 
   let args =
     List.map
@@ -400,14 +383,14 @@ let gen_from_type_declaration ~loc td =
   let gen =
     match td.ptype_kind with
     | Ptype_variant xs ->
-       let is_rec cd = is_rec_constr_decl (curr_types ()) cd in
-       gen_sized ~loc is_rec (gen_from_constr ~loc) xs
+       let is_rec cd = is_rec_constr_decl env cd in
+       gen_sized ~loc is_rec (gen_from_constr ~loc ~env) xs
     | Ptype_record xs ->
-        let gens = List.map (fun x -> gen_from_type ~loc  x.pld_type) xs in
+        let gens = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
         gen_record ~loc ~gens xs
     | _ ->
         let typ = Option.get td.ptype_manifest in
-        gen_from_type ~loc  typ
+        gen_from_type ~loc ~env typ
   in
 
   let pat_gen = pat ~loc ty in
@@ -427,7 +410,6 @@ let gen_from_type_declaration ~loc td =
         [%stri let [%p pat_gen] = [%e gen_normal]]
       )
 
-(** *)
 let mutually_recursive_gens ~loc gens =
   let (module A) = Ast_builder.make loc in
   let to_mutualize_gens =
@@ -450,37 +432,36 @@ let mutually_recursive_gens ~loc gens =
   let mutual_gens = A.pstr_value Recursive gens in
   mutual_gens :: normal_gens
 
-(** [derive_gen ~loc xs] creates generators for type declaration in [xs].
-
-    It also has a hidden purpose: it sets the environment prior to
-    the derivation. It identifies recursive types declarations (e.g. list)
-    and its external arguments (e.g. 'a list).
-*)
+(** [derive_gen ~loc xs] creates generators for type declaration in [xs]. *)
 let derive_gen ~loc (xs : rec_flag * type_declaration list) : structure =
-  (match xs with
+  let open Env in
+  let add_if_rec env typ x =
+    if is_rec_type_decl env typ then
+      { env with rec_types = x :: env.rec_types}
+    else env
+  in
+  match xs with
   | (_, [ x ]) ->
-     let () = set_curr_types x.ptype_name.txt [x.ptype_name.txt] in
-     let () = add_env [x.ptype_name.txt] x.ptype_name.txt x in
-     (match gen_from_type_declaration ~loc x with
-     | `Recursive (gen_sized, gen) -> [gen_sized; gen]
-     | `Normal gen -> [gen])
+     let typ_name = x.ptype_name.txt in
+     let env = { curr_type = typ_name; rec_types = []; curr_types = [typ_name] } in
+     let env = add_if_rec env x typ_name in
+     (match gen_from_type_declaration ~loc ~env x with
+      | `Recursive (gen_sized, gen) -> [gen_sized; gen]
+      | `Normal gen -> [gen])
   | _, xs ->
      let typ_names = List.map (fun x -> x.ptype_name.txt) xs in
-     let () =
-       List.map (fun x -> (x.ptype_name.txt, x)) xs |>
-         List.iter (fun (x, y) -> add_env typ_names x y)
+     let env = { curr_type = ""; rec_types = []; curr_types = typ_names } in
+     let env =
+       List.fold_left
+         (fun env x -> add_if_rec env x x.ptype_name.txt)
+         env xs
      in
      let gens =
        List.map (fun x ->
-           let () = set_curr_types x.ptype_name.txt typ_names in
-           gen_from_type_declaration ~loc x) xs
+           let env = { env with curr_type = x.ptype_name.txt }in
+           gen_from_type_declaration ~loc ~env x) xs
      in
-     mutually_recursive_gens ~loc gens)
-  |>
-    fun res ->
-    let () = clean_env () in
-    let () = clean_curr_types () in
-    res
+     mutually_recursive_gens ~loc gens
 
 (** {2. Ppxlib machinery} *)
 

From 31f328f9ec8fb0433c5ad2f36c7c51fabcad3e79 Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Fri, 10 Dec 2021 16:40:55 +0100
Subject: [PATCH 08/10] Add ppx_deriving dependency

---
 ppx_deriving_qcheck.opam | 1 +
 1 file changed, 1 insertion(+)

diff --git a/ppx_deriving_qcheck.opam b/ppx_deriving_qcheck.opam
index 81e719ce..b4ca4220 100644
--- a/ppx_deriving_qcheck.opam
+++ b/ppx_deriving_qcheck.opam
@@ -12,6 +12,7 @@ depends: [
   "ocaml" {>= "4.08.0"}
   "qcheck" {>= "0.17"}
   "ppxlib" {>= "0.22.0"}
+  "ppx_deriving" {>= "5.2.1"}
   "odoc" {with-doc}
   "alcotest" {with-test & >= "1.4.0" }
 ]

From 6a4f816a8d49e897f5d2c017cbe1495369b1e27a Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Mon, 13 Dec 2021 10:35:03 +0100
Subject: [PATCH 09/10] Fix indentation

---
 src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index f9ccbc24..e9723fa3 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -266,9 +266,10 @@ let rec gen_from_type ~loc ~env typ =
           let tys = List.map (gen_from_type ~loc ~env) typs in
           gen_tuple ~loc tys
       | { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, args); _ } ->
-         let args = List.map (gen_from_type ~loc ~env) args in
-         gen_longident ~loc ~env ty args
-      | { ptyp_desc = Ptyp_var s; _ } -> gen_longident ~loc ~env (Lident s) []
+          let args = List.map (gen_from_type ~loc ~env) args in
+          gen_longident ~loc ~env ty args
+      | { ptyp_desc = Ptyp_var s; _ } ->
+          gen_longident ~loc ~env (Lident s) []
       | { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
           gen_from_variant ~loc ~env rws
       | { ptyp_desc = Ptyp_arrow (_, left, right); _ } ->
@@ -383,8 +384,8 @@ let gen_from_type_declaration ~loc ~env td =
   let gen =
     match td.ptype_kind with
     | Ptype_variant xs ->
-       let is_rec cd = is_rec_constr_decl env cd in
-       gen_sized ~loc is_rec (gen_from_constr ~loc ~env) xs
+        let is_rec cd = is_rec_constr_decl env cd in
+        gen_sized ~loc is_rec (gen_from_constr ~loc ~env) xs
     | Ptype_record xs ->
         let gens = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
         gen_record ~loc ~gens xs

From e0d544a07bd0b9a298179ea8e63c82cfafc3546a Mon Sep 17 00:00:00 2001
From: Valentin Chaboche <valentin.chaboche@nomadic-labs.com>
Date: Mon, 13 Dec 2021 10:38:59 +0100
Subject: [PATCH 10/10] Rename qcheck_generators to QCheck_generators

---
 .../{qcheck_generators.ml => QCheck_generators.ml}            | 0
 src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml                | 2 +-
 src/ppx_deriving_qcheck/tuple.ml                              | 4 ++--
 3 files changed, 3 insertions(+), 3 deletions(-)
 rename src/ppx_deriving_qcheck/{qcheck_generators.ml => QCheck_generators.ml} (100%)

diff --git a/src/ppx_deriving_qcheck/qcheck_generators.ml b/src/ppx_deriving_qcheck/QCheck_generators.ml
similarity index 100%
rename from src/ppx_deriving_qcheck/qcheck_generators.ml
rename to src/ppx_deriving_qcheck/QCheck_generators.ml
diff --git a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
index e9723fa3..a1d73b68 100644
--- a/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
+++ b/src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml
@@ -1,5 +1,5 @@
 open Ppxlib
-module G = Qcheck_generators
+module G = QCheck_generators
 module O = G.Observable
 
 (** {1. ppx_deriving_qcheck} *)
diff --git a/src/ppx_deriving_qcheck/tuple.ml b/src/ppx_deriving_qcheck/tuple.ml
index eac01bde..89194154 100644
--- a/src/ppx_deriving_qcheck/tuple.ml
+++ b/src/ppx_deriving_qcheck/tuple.ml
@@ -1,6 +1,6 @@
 open Ppxlib
-module G = Qcheck_generators
-module O = Qcheck_generators.Observable
+module G = QCheck_generators
+module O = G.Observable
 
 (** {1. Tuple } *)