Merge pull request #195 from vch9/fix188

Deriver: share fuel between mutual generators

Author: jmid

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" }
 ]

src/ppx_deriving_qcheck/QCheck_generators.ml

@@ -0,0 +1,96 @@
+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 =
+  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]]
+
+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

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:
@@ -238,20 +248,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.frequency
-            [(1, (QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int))]
-        | n ->
-          QCheck.Gen.frequency
-            [(1,
-               (QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int));
-             (1,
-               (QCheck.Gen.map (fun (gen0, 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

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