Merge pull request #171 from vch9/master

add ppx_deriving_qcheck

Author: jmid

AUTHORS

@@ -2,3 +2,4 @@ Simon Cruanes <[email protected]>
 Rudi Grinberg <[email protected]>
 Jacques-Pascal Deplaix <[email protected]>
 Jan Midtgaard <[email protected]>
+Valentin Chaboche <[email protected]>

README.adoc

@@ -402,6 +402,18 @@ describe("qcheck-rely", ({test}) => {
 
 ----
 
+=== Deriver
+
+A ppx_deriver is provided to derive QCheck generators from a type declaration.
+
+```ocaml
+type tree = Leaf of int | Node of tree * tree
+[@@deriving qcheck]
+```
+
+See the according https://github.com/c-cube/qcheck/tree/master/src/ppx_deriving_qcheck/[README]
+for more information and examples.
+
 === Compatibility notes
 
 Starting with 0.9, the library is split into several components:

ppx_deriving_qcheck.opam

@@ -0,0 +1,27 @@
+opam-version: "2.0"
+name: "ppx_deriving_qcheck"
+version: "0.2.0"
+license: "BSD-2-Clause"
+synopsis: "PPX Deriver for QCheck"
+
+maintainer: "[email protected]"
+author: [ "the qcheck contributors" ]
+
+depends: [
+  "dune" {>= "2.8.0"}
+  "ocaml" {>= "4.08.0"}
+  "qcheck" {>= "0.17"}
+  "ppxlib" {>= "0.22.0"}
+  "odoc" {with-doc}
+  "alcotest" {with-test & >= "1.4.0" }
+]
+
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+
+homepage: "https://github.com/c-cube/qcheck/"
+bug-reports: "https://github.com/c-cube/qcheck/-/issues"
+dev-repo: "git+https://github.com/vch9/ppx_deriving_qcheck.git"

src/ppx_deriving_qcheck/README.md

@@ -0,0 +1,307 @@
+# ppx_deriving_qcheck
+
+## Generator
+Derive `QCheck.Gen.t` from a type declaration
+
+```ocaml
+type tree = Leaf of int | Node of tree * tree
+[@@deriving qcheck]
+
+let rec rev tree = match tree with
+| Leaf _ -> tree
+| Node (left, right) -> Node (rev left, rev right)
+
+let test =
+  QCheck.Test.make
+    ~name:"tree -> rev (rev tree) = tree"
+	(QCheck.make gen_tree)
+	(fun tree -> rev (rev tree) = tree)
+```
+
+### Overwrite generator
+If you wan't to specify your own `generator` for any type you can
+add an attribute to the type:
+
+```ocaml
+type t = (int : [@gen QCheck.Gen.(0 -- 10)])
+[@@deriving qcheck]
+
+(* produces ==> *)
+
+let gen : t QCheck.Gen.t = QCheck.Gen.(0 -- 10)
+```
+
+This attribute has 2 advantages:
+* Use your own generator for a specific type (see above)
+* There is no generator available for the type
+  ```ocaml
+  type my_foo =
+  | Foo of my_other_type
+  | Bar of bool
+  [@@deriving qcheck]
+  ^^^^^^^^^^^^^^^^
+  Error: Unbound value gen_my_other_type
+  
+  (* Possible fix *)
+  let gen_my_other_type = (* add your implementation here *)
+  
+  type my_foo =
+  | Foo of my_other_type [@gen gen_my_other_type]
+  | Bar of bool
+  [@@deriving qcheck]
+  ```
+
+## How to use
+
+Add to your OCaml libraries with dune
+```ocaml
+...
+(preprocess (pps ppx_deriving_qcheck)))
+...
+```
+
+## Supported types
+
+### Primitive types
+
+* Unit
+```ocaml
+type t = unit [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.unit
+```
+
+* Bool
+```ocaml
+type t = bool [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.bool
+```
+
+* Integer
+```ocaml
+type t = int [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.int
+```
+
+* Float
+```ocaml
+type t = float [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.float
+```
+
+* String
+```ocaml
+type t = string [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.string
+```
+
+* Char
+```ocaml
+type t = char [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.char
+```
+
+* Option
+```ocaml
+type 'a t = 'a option [@@deriving qcheck]
+
+(* ==> *)
+
+let gen gen_a = QCheck.Gen.option gen_a
+```
+
+* List
+```ocaml
+type 'a t = 'a list [@@deriving qcheck]
+
+(* ==> *)
+
+let gen gen_a = QCheck.Gen.list gen_a
+```
+
+* Array
+```ocaml
+type 'a t = 'a array [@@deriving qcheck]
+
+(* ==> *)
+
+let gen gen_a = QCheck.Gen.array gen_a
+```
+
+### Tuples of size `n`
+
+* n = 2
+```ocaml
+type t = int * int [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int
+```
+
+* n = 3
+```ocaml
+type t = int * int * int [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int
+```
+
+* n = 4
+```ocaml
+type t = int * int * int * int [@@deriving qcheck]
+
+(* ==> *)
+
+let gen = QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int
+```
+
+* n > 4, tuples are split between pairs, for instance n = 8
+```ocaml
+type t = int * int * int * int * int * int * int * int [@@deriving qcheck]
+
+(* ==> *)
+
+let gen =
+  QCheck.Gen.pair
+    (QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)
+    (QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)
+```
+
+## Records
+```ocaml
+type service = {
+	service_name : string;
+	port : int;
+	protocol : string;
+} [@@deriving qcheck]
+
+(* ==> *)
+
+let gen_service =
+  QCheck.Gen.map
+    (fun (gen0, gen1, gen2) ->
+      { service_name = gen0; port = gen1; protocol = gen2 })
+    (QCheck.Gen.triple QCheck.Gen.string QCheck.Gen.int QCheck.Gen.string)
+```
+
+## Variants
+* Variants
+```ocaml
+type color = Red | Blue | Green
+[@@deriving qcheck]
+
+(* ==> *)
+
+let gen_color =
+  QCheck.Gen.frequency
+    [(1, (QCheck.Gen.pure Red));
+     (1, (QCheck.Gen.pure Blue));
+     (1, (QCheck.Gen.pure Green))]
+```
+
+* Polymorphic variants
+```ocaml
+type color = [ `Red | `Blue | `Green ]
+[@@deriving qcheck]
+
+(* ==> *)
+
+let gen_color =
+  (QCheck.Gen.frequency
+    [(1, (QCheck.Gen.pure `Red));
+     (1, (QCheck.Gen.pure `Blue));
+     (1, (QCheck.Gen.pure `Green))] : color QCheck.Gen.t)
+```
+
+## Recursive variants
+* Recursive variants
+```ocaml
+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)))))]))
+```
+
+* Recursive polymorphic variants
+```ocaml
+type tree = [ `Leaf of int | `Node of tree * tree ]
+[@@deriving qcheck]
+
+(* ==> *)
+
+/!\ FIXME: https://github.com/vch9/ppx_deriving_qcheck/issues/7 /!\
+```
+
+## Mutual recursive types
+```ocaml
+type tree = Node of (int * forest)
+and forest = Nil | Cons of (tree * forest)
+[@@deriving qcheck]
+
+(* ==> *)
+
+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 ())))))]
+
+and gen_forest () =
+  QCheck.Gen.sized @@
+    (QCheck.Gen.fix
+      (fun self -> function
+        | 0 -> QCheck.Gen.frequency [(1, (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))))))]))
+
+let gen_tree = gen_tree ()
+
+let gen_forest = gen_forest ()
+```
+
+## Unsupported types
+
+### GADT
+Deriving a GADT currently produces an ill-typed generator.
+
+### Let us know
+If you encounter a unsupported type (that should be), please let us know by creating
+an issue.

src/ppx_deriving_qcheck/attributes.ml

@@ -0,0 +1,19 @@
+open Ppxlib
+
+(** [find_first_attribute xs name] returns the first attribute found in [xs]
+    named [name] *)
+let find_attribute_opt xs name =
+  List.find_opt (fun attribute -> attribute.attr_name.txt = name) xs
+
+let get_expr_payload x =
+  match x.attr_payload with
+  | PStr [ { pstr_desc = Pstr_eval (e, _); _ } ] -> Some [%expr [%e e]]
+  | _ -> None
+
+let gen ct =
+  Option.fold ~none:None ~some:get_expr_payload
+  @@ find_attribute_opt ct.ptyp_attributes "gen"
+
+let weight xs =
+  Option.fold ~none:None ~some:get_expr_payload
+  @@ find_attribute_opt xs "weight"