From b4f3925a459f90ea1cb0e860ea113705f1473e65 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Sat, 28 Sep 2013 12:43:38 +0200
Subject: [PATCH] QCheck easier to use, with printing combinators module and
 simpler ('a -> bool) properties

---
 qCheck.ml  | 101 ++++++++++++++++++++++++++++++++---------------------
 qCheck.mli |  51 +++++++++++++++++----------
 2 files changed, 93 insertions(+), 59 deletions(-)

diff --git a/qCheck.ml b/qCheck.ml
index 999b3ef9..dde3a49f 100644
--- a/qCheck.ml
+++ b/qCheck.ml
@@ -29,14 +29,16 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 module Arbitrary = struct
   type 'a t = Random.State.t -> 'a
 
-  let int st = Random.State.int st max_int
+  let int n st = Random.State.int st n
 
-  let int_range ?(start=0) ~stop st =
+  let int_range ~start ~stop st =
     let n = stop - start in
     if n <= 0
       then 0
       else start + Random.State.int st n
 
+  let small_int = int 100
+
   let bool = Random.State.bool
 
   let float f st = Random.State.float st f
@@ -46,7 +48,7 @@ module Arbitrary = struct
   let alpha st =
     Char.chr (Char.code 'a' + Random.State.int st (Char.code 'z' - Char.code 'a'))
 
-  let string ~len st =
+  let string_len len st =
     let n = len st in
     assert (n>=0);
     let s = String.create n in
@@ -55,6 +57,8 @@ module Arbitrary = struct
     done;
     s
 
+  let string st = string_len (int 10) st
+
   let map ar f st = f (ar st)
 
   let rec _make_list ar st acc n =
@@ -62,7 +66,7 @@ module Arbitrary = struct
       let x = ar st in
       _make_list ar st (x::acc) (n-1)
 
-  let list ~len ar st =
+  let list ?(len=int 10) ar st =
     let n = len st in
     _make_list ar st [] n
 
@@ -74,7 +78,7 @@ module Arbitrary = struct
   let list_repeat len ar st =
     _make_list ar st [] len
 
-  let array ~len ar st =
+  let array ?(len=int 10) ar st =
     let n = len st in
     Array.init n (fun _ -> ar st)
 
@@ -118,41 +122,57 @@ module Arbitrary = struct
     fix ~max ~base f st
 end
 
+(** {2 Pretty printing} *)
+
+module PP = struct
+  type 'a t = 'a -> string
+
+  let int = string_of_int
+  let bool = string_of_bool
+  let float = string_of_float
+  let string s = s
+  let char c =
+    let s = "_" in
+    s.[0] <- c;
+    s
+
+  let list pp l =
+    let b = Buffer.create 25 in
+    Buffer.add_char b '(';
+    List.iteri (fun i x ->
+      if i > 0 then Buffer.add_string b ", ";
+      Buffer.add_string b (pp x))
+      l;
+    Buffer.add_char b ')';
+    Buffer.contents b
+
+  let array pp a = 
+    let b = Buffer.create 25 in
+    Buffer.add_char b '[';
+    Array.iteri (fun i x ->
+      if i > 0 then Buffer.add_string b ", ";
+      Buffer.add_string b (pp x))
+      a;
+    Buffer.add_char b ']';
+    Buffer.contents b
+end
+
 (** {2 Testing} *)
 
 module Prop = struct
-  type 'a t = {
-    name : string;
-    precond : 'a -> bool;
-    test: 'a -> bool;
-  } (** A simple property on elements of type 'a *)
+  type 'a t = 'a -> bool
+
+  exception PrecondFail
   
-  let __true _ = true
-
-  let make_prop ?(precond=__true) name test = {
-    precond;
-    name;
-    test;
-  }
-
-  let (>::) name test = make_prop name test
-
   let (==>) a b =
-    { b with precond = (fun x -> a x && b.precond x); }
+    fun x ->
+      if not (a x) then raise PrecondFail else b x
 
-  let (&&&) a b =
-    { precond = (fun x -> a.precond x && b.precond x);
-      name = Printf.sprintf "%s and %s" a.name b.name;
-      test = (fun x -> a.test x && b.test x);
-    }
+  let (&&&) a b x = a x && b x
 
-  let (|||) a b =
-    { precond = (fun x -> a.precond x && b.precond x);
-      name = Printf.sprintf "%s or %s" a.name b.name;
-      test = (fun x -> a.test x || b.test x);
-    }
+  let (|||) a b x = a x || b x
 
-  let (!!!) a = { a with name = "not " ^ a.name; test = (fun x -> not (a.test x)); }
+  let (!!!) a x = not (a x)
 end
 
 type 'a result =
@@ -160,16 +180,17 @@ type 'a result =
   | Failed of 'a list
   | Error of exn
 
-let check ?(rand=Random.State.make_self_init ()) ?(n=100) ~gen ~prop =
+let check ?(rand=Random.State.make_self_init ()) ?(n=100) gen prop =
   let precond_failed = ref 0 in
   let failures = ref [] in
   try
     for i = 0 to n - 1 do
       let x = gen rand in
-      if not (prop.Prop.precond x)
-        then incr precond_failed
-      else if not (prop.Prop.test x)
-        then failures := x :: !failures
+      try
+        if not (prop x)
+          then failures := x :: !failures
+      with Prop.PrecondFail ->
+        incr precond_failed
     done;
     match !failures with
     | [] -> Ok (n, !precond_failed)
@@ -179,9 +200,9 @@ let check ?(rand=Random.State.make_self_init ()) ?(n=100) ~gen ~prop =
 
 (** {2 Main} *)
 
-let run ?pp ?n ~rand ~gen ~prop =
-  Printf.printf "testing property %s...\n" prop.Prop.name;
-  match check ~rand ?n ~gen ~prop with
+let run ?pp ?n ?(rand=Random.State.make_self_init()) ?(name="<no name>") gen prop =
+  Printf.printf "testing property %s...\n" name;
+  match check ~rand ?n gen prop with
   | Ok (n, prefail) ->
     Printf.printf "passed %d tests (%d preconditions failed)\n" n prefail;
     true
diff --git a/qCheck.mli b/qCheck.mli
index baf7b1c4..ba7de508 100644
--- a/qCheck.mli
+++ b/qCheck.mli
@@ -32,12 +32,15 @@ module Arbitrary : sig
   type 'a t = Random.State.t -> 'a
     (** A generator of arbitrary values of type 'a *)
 
-  val int : int t
+  val int : int -> int t
     (** Any integer *)
 
-  val int_range : ?start:int -> stop:int -> int t
+  val int_range : start:int -> stop:int -> int t
     (* Integer range *)
 
+  val small_int : int t
+    (** Ints lower than 100 *)
+
   val bool : bool t
     (** Arbitrary boolean *)
 
@@ -50,13 +53,16 @@ module Arbitrary : sig
   val float : float -> float t
     (** Random float *)
 
-  val string : len:int t -> string t
+  val string : string t
+    (** Random strings of small length *)
+
+  val string_len : int t -> string t
     (** String of random length *)
 
   val map : 'a t -> ('a -> 'b) -> 'b t
     (** Transform an arbitrary into another *)
 
-  val list : len:int t -> 'a t -> 'a list t
+  val list : ?len:int t -> 'a t -> 'a list t
     (** List of arbitrary length *)
 
   val opt : 'a t -> 'a option t
@@ -65,7 +71,7 @@ module Arbitrary : sig
   val list_repeat : int -> 'a t -> 'a list t
     (** Lists of given length exactly *)
 
-  val array : len:int t -> 'a t -> 'a array t
+  val array : ?len:int t -> 'a t -> 'a array t
     (** Random array of random length *)
 
   val array_repeat : int -> 'a t -> 'a array t
@@ -91,19 +97,25 @@ module Arbitrary : sig
     (** Recursive values of at most given random depth *)
 end
 
+(** {2 Pretty printing} *)
+
+module PP : sig
+  type 'a t = 'a -> string
+
+  val int : int t
+  val bool : bool t
+  val float : float t
+  val char : char t
+  val string : string t
+
+  val list : 'a t -> 'a list t
+  val array : 'a t -> 'a array t
+end
+
 (** {2 Testing} *)
 
 module Prop : sig
-  type 'a t = {
-    name : string;
-    precond : 'a -> bool;
-    test: 'a -> bool;
-  } (** A simple property on elements of type 'a *)
-
-  val (>::) : string -> ('a -> bool) -> 'a t
-    (** Build a test with the given name *)
-
-  val make_prop : ?precond:('a -> bool) -> string -> ('a -> bool) -> 'a t
+  type 'a t = 'a -> bool
 
   val (==>) : ('a -> bool) -> 'a t -> 'a t
     (** Precondition for a test *)
@@ -123,15 +135,16 @@ type 'a result =
   | Failed of 'a list
   | Error of exn
 
-val check : ?rand:Random.State.t -> ?n:int ->
-            gen:'a Arbitrary.t -> prop:'a Prop.t -> 'a result
+val check : ?rand:Random.State.t -> ?n:int -> 
+            'a Arbitrary.t -> 'a Prop.t -> 'a result
   (** Check that the property [prop] holds on [n] random instances of the type
       'a, as generated by the arbitrary instance [gen] *)
 
 (** {2 Main} *)
 
-val run : ?pp:('a -> string) -> ?n:int -> rand:Random.State.t -> 
-          gen:'a Arbitrary.t -> prop:'a Prop.t -> bool
+val run : ?pp:('a -> string) -> ?n:int ->
+          ?rand:Random.State.t -> ?name:string ->
+          'a Arbitrary.t -> 'a Prop.t -> bool
   (** Run and print result *)
 
 val run_tests : (rand:Random.State.t -> bool) list -> bool