/quickCheck.ml

  1module Random = struct
  2  include Random
  3  let int n = int (max n 1)
  4  let char : char -> char =
  5    fun lim ->
  6      let l = Char.code lim in
  7      let i = int l in
  8      Char.chr i
  9  let int_range : int * int -> int =
 10    fun (lo, hi) ->
 11      lo + int (hi-lo)
 12  let int32_range : Int32.t * Int32.t -> Int32.t =
 13    fun (lo, hi) ->
 14      Int32.add lo (int32 (Int32.sub hi lo))
 15  let int64_range : Int64.t * Int64.t -> Int64.t =
 16    fun (lo, hi) ->
 17      Int64.add lo (int64 (Int64.sub hi lo))
 18  let nativeint_range : Nativeint.t * Nativeint.t -> Nativeint.t =
 19    fun (lo, hi) ->
 20      Nativeint.add lo (nativeint (Nativeint.sub hi lo))
 21  let float_range : float * float -> float =
 22    fun (lo, hi) ->
 23      lo +. float (hi -. lo)
 24  let char_range : char * char -> char =
 25    fun (lo, hi) ->
 26      let lo' = Char.code lo and hi' = Char.code hi in
 27      let i = int_range (lo', hi') in
 28      Char.chr i
 29end
 30
 31module List = struct
 32  include List
 33  let rec span : ('a -> bool) -> 'a list -> 'a list * 'a list =
 34    fun p -> function
 35        [] -> [],[]
 36      | x::xs when p x ->
 37          let ys,zs = span p xs in
 38          (x::ys,zs)
 39      | xs -> [],xs
 40
 41  let rec groupBy : ('a -> 'a -> bool) -> 'a list -> 'a list list =
 42    fun p -> function
 43        [] -> []
 44      | x::xs ->
 45          let ys,zs = span (p x) xs in
 46          (x::ys) :: groupBy p zs
 47
 48  let group xs = groupBy (=) xs
 49end
 50
 51type 'a gen = Gen of (int -> 'a)
 52type pretty_str = Format.formatter -> unit -> unit
 53
 54module type PSHOW = sig
 55  type t
 56  val show : t -> pretty_str
 57end
 58
 59module type SHOW = sig
 60  type t
 61  val show : t -> string
 62end
 63
 64module Show(P:PSHOW) = struct
 65  open Buffer
 66  open Format
 67  type t = P.t
 68  let show : t -> string =
 69    fun x ->
 70      let f _ =
 71        let str = contents stdbuf in
 72        clear stdbuf;
 73        str
 74      in
 75      clear stdbuf;
 76      kfprintf f str_formatter "@[%a@]@?" (P.show x) ()
 77end
 78
 79module PShow_list(Elt:PSHOW) = struct
 80  type t = Elt.t list
 81  let show : t -> pretty_str =
 82    fun xs fmt () ->
 83      let pp = Format.fprintf in
 84      match List.map Elt.show xs with
 85          [] -> pp fmt "[]"
 86        | a1::an ->
 87            let pprest f =
 88              List.iter (fun e -> pp f ";@ %a" e ())
 89            in
 90	    pp fmt "[%a%a]" a1 () pprest an
 91end
 92
 93module PShow_char = struct
 94  type t = char
 95  let show : t -> pretty_str =
 96    fun c fmt () ->
 97      Format.fprintf fmt "%C" c
 98end
 99
100module PShow_int = struct
101  type t = int
102  let show : t -> pretty_str =
103    fun c fmt () ->
104      Format.fprintf fmt "%d" c
105end
106
107(* generator functions *)
108
109let sized : (int -> 'a gen) -> 'a gen =
110  fun f -> Gen (fun n ->
111                  let Gen m = f n in
112                  m n)
113
114let resize : int -> 'a gen -> 'a gen =
115  fun n (Gen m) -> Gen (fun _ -> m n)
116
117let promote : ('a -> 'b gen) -> ('a -> 'b) gen =
118  fun f ->
119    Gen (fun n ->
120           fun a ->
121             let Gen m = f a in
122             m n)
123
124let variant : int -> 'a gen -> 'a gen =
125  fun _v (Gen m) -> Gen (fun n -> m n)
126
127let generate : int -> 'a gen -> 'a =
128  fun n (Gen m) ->
129    let size = Random.int n in
130    m size
131
132let map_gen : ('a -> 'b) -> 'a gen -> 'b gen =
133  fun f (Gen m) ->
134    Gen (fun n ->
135           let v = m n in
136           f v)
137
138let ret_gen : 'a -> 'a gen =
139  fun a -> Gen (fun _n -> a)
140
141let (>>=) : 'a gen -> ('a -> 'b gen) -> 'b gen =
142  fun (Gen m) k ->
143    Gen (fun n ->
144           let v = m n in
145           let Gen m' = k v in
146           m' n)
147
148let lift_gen : ('a -> 'b) -> 'a -> 'b gen =
149  fun f -> fun a -> Gen (fun _ -> f a)
150
151let choose_int = lift_gen Random.int_range
152let choose_int0 = lift_gen Random.int
153let choose_char = lift_gen Random.char_range
154let choose_float = lift_gen Random.float_range
155
156let elements : 'a list -> 'a gen =
157  fun xs ->
158    map_gen (List.nth xs)
159      (choose_int0 (List.length xs))
160
161let vector : 'a gen -> int -> 'a list gen =
162  fun (Gen gelt) l ->
163    Gen (fun n ->
164           let rec gen acc = function
165               0 -> acc
166             | l -> gen (gelt n :: acc) (l-1)
167           in gen [] l)
168
169let oneof : 'a gen list -> 'a gen =
170  fun gens -> elements gens >>= fun x -> x
171
172module type ARBITRARY = sig
173  type t
174  val arbitrary : t gen
175end
176
177module Arbitrary_unit = struct
178  type t = unit
179  let arbitrary = ret_gen ()
180end
181
182module Arbitrary_bool = struct
183  type t = bool
184  let arbitrary = elements [true; false]
185end
186
187module Arbitrary_char = struct
188  type t = char
189  let arbitrary =
190    choose_int (32,255) >>= fun c -> 
191      ret_gen (Char.chr c)
192end
193
194module Arbitrary_int = struct
195  type t = int
196  let arbitrary = sized (fun n -> choose_int (-n, n))
197end
198
199module Arbitrary_float = struct
200  type t = float
201  let arbitrary =
202    Arbitrary_int.arbitrary >>= fun a ->
203      Arbitrary_int.arbitrary >>= fun b ->
204        sized choose_int0 >>= fun c ->
205          ret_gen
206            (float a +. (float b /. (float c +. 1.)))
207end
208
209module Aribitrary_pair(Fst:ARBITRARY)(Snd:ARBITRARY) = struct
210  type t = Fst.t * Snd.t
211  let arbitrary =
212    Fst.arbitrary >>= fun v1 ->
213      Snd.arbitrary >>= fun v2 ->
214        ret_gen (v1,v2)
215end
216
217module Aribitrary_triple(Fst:ARBITRARY)(Snd:ARBITRARY)(Trd:ARBITRARY) = struct
218  type t = Fst.t * Snd.t * Trd.t
219  let arbitrary =
220    Fst.arbitrary >>= fun v1 ->
221      Snd.arbitrary >>= fun v2 ->
222        Trd.arbitrary >>= fun v3 ->
223          ret_gen (v1,v2,v3)
224end
225
226module Arbitrary_list(Elt:ARBITRARY) = struct
227  type t = Elt.t list
228  let arbitrary =
229    sized choose_int0 >>= vector Elt.arbitrary
230end
231
232(*********** testable ************)
233
234type result = {
235  ok : bool option;
236  stamp : string list;
237  arguments : pretty_str list;
238}
239
240type property = Prop of result gen
241
242module type TESTABLE = sig
243  type t
244  val property : t -> property
245end
246
247let nothing : result = {ok=None; stamp=[]; arguments=[]}
248
249let result : result -> property =
250  fun res -> Prop (ret_gen res)
251
252module Testable_unit = struct
253  type t = unit
254  let property () = result nothing
255end
256
257module Testable_bool = struct
258  type t = bool
259  let property b = result {nothing with ok=Some b}
260end
261
262module Testable_result = struct
263  type t = result
264  let property r = result r
265end
266
267module Testable_property = struct
268  type t = property
269  let property p = p
270end
271
272module Evaluate(T:TESTABLE) = struct
273  let evaluate : T.t -> result gen =
274    fun a ->
275      let Prop gen = T.property a in
276      gen
277end
278
279module ForAll(S:PSHOW)(T:TESTABLE) = struct
280  module E = Evaluate(T)
281  let forAll : S.t gen -> (S.t -> T.t) -> property =
282  fun gen body ->
283    let argument a res =
284      { res with arguments = S.show a ::res.arguments }
285    in
286    Prop
287      (gen >>= fun a ->
288         E.evaluate (body a) >>= fun res ->
289           ret_gen (argument a res))
290end
291
292module Testable_fun
293  (A:ARBITRARY)
294  (S:PSHOW with type t = A.t)
295  (T:TESTABLE) =
296struct
297  module F = ForAll(S)(T)
298  type t = A.t -> T.t
299  let property : t -> property =
300    fun f ->
301      F.forAll A.arbitrary f
302end
303
304module Implies(T:TESTABLE) = struct
305  let (==>) : bool -> T.t -> property =
306    fun b a ->
307      if b
308      then T.property a
309      else Testable_unit.property ()
310end
311
312module Label(T:TESTABLE) = struct
313  module E = Evaluate(T)
314  let label : string -> T.t -> property =
315    fun s a ->
316      let add r = {r with stamp = s :: r.stamp } in
317      let a' = E.evaluate a in
318      Prop (map_gen add a')
319end
320
321module Classify(T:TESTABLE) = struct
322  module L = Label(T)
323  let classify : bool -> string -> T.t -> property =
324    function
325        true -> L.label
326      | false -> fun _ -> T.property
327  let trivial : bool -> T.t -> property =
328    fun b -> classify b "trivial"
329end
330
331module Collect(S:SHOW)(T:TESTABLE) = struct
332  module L = Label(T)
333  let collect : S.t -> T.t -> property =
334    fun v -> L.label (S.show v)
335end
336
337type config = {
338  maxTest : int;
339  maxFail : int;
340  size    : int -> int;
341  every   : Format.formatter -> int * pretty_str list -> unit;
342}
343
344let quick = {
345  maxTest = 100;
346  maxFail = 1000;
347  size    = (fun n -> 3 + n / 2);
348  every   = (fun _ (_, _) -> ()) 
349}
350
351let verbose = {
352  quick with
353    every = begin fun f (n, args) ->
354      let pargs fmt l =
355        List.iter (fun a -> Format.fprintf fmt "@ %a" a ()) l
356      in
357      Format.fprintf f "@[%d:@[<hov 2>%a@]@]@." n pargs args
358    end
359}
360
361let done_ : string -> int -> string list list -> unit =
362  fun mesg ntest stamps ->
363    let percentage n m =
364      Format.sprintf "%2d%%" ((100 * n) / m)
365    in
366    let entry (n, xs) =
367      Format.sprintf "%s %s" (percentage n ntest) (String.concat ", " xs)
368    in
369    let pairLength = function
370        (xs::_) as xss -> (List.length xss, xs)
371      | [] -> assert false
372    in
373    let display = function
374        [] -> ".\n"
375      | [x] -> Format.sprintf " (%s).\n" x
376      | xs ->
377          String.concat "\n" ("." :: List.map (Format.sprintf "%s.") xs)
378    in
379    let not_null = function [] -> false | _ -> true in
380    let table =
381      display
382        (List.map entry
383           (List.rev
384              (List.sort compare
385                 (List.map pairLength
386                    (List.group
387                       (List.sort compare
388                          (List.filter not_null
389                             stamps)))))))
390    in
391    Format.printf "%s %d tests%s" mesg ntest table
392
393let rec tests : config -> result gen -> int -> int -> string list list -> unit =
394    fun config gen ntest nfail stamps ->
395      if ntest = config.maxTest
396      then done_ "OK, passed" ntest stamps
397      else if nfail = config.maxFail
398      then done_ "Arguments exhausted after" nfail stamps
399      else begin
400        let result = generate (config.size ntest) gen in
401        let () =
402          Format.printf "@[%a@]@?" config.every (ntest, result.arguments)
403        in
404        match result.ok with
405            None ->
406              tests config gen ntest (nfail+1) stamps
407          | Some true ->
408              tests config gen (ntest+1) nfail (result.stamp :: stamps)
409          | Some false ->
410              let p f = function
411                  [] -> ()
412                | h::t ->
413                    h f ();
414                    List.iter (fun s -> Format.fprintf f "@ %a" s ()) t
415              in
416              Format.printf "@[<2>Falsifiable, after %d tests:@ %a@]@."
417                ntest p result.arguments
418      end
419
420module Check(T:TESTABLE) = struct
421  module E=Evaluate(T)
422  let check : config -> T.t -> unit =
423    fun config a ->
424      tests config (E.evaluate a) 0 0 []
425  let test = check quick
426  let quickCheck = test
427  let verboseCheck = check verbose
428end
429
430(* (set (make-local-variable 'flymake-ocaml-build-file) "Makefile") *)