/quickCheck.ml
OCaml | 430 lines | 370 code | 57 blank | 3 comment | 6 complexity | b815f97d8f451522fb4697ce531154b5 MD5 | raw file
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") *)