/quickCheck.ml

http://github.com/alanfalloon/ocaml-quickcheck · OCaml · 430 lines · 370 code · 57 blank · 3 comment · 6 complexity · b815f97d8f451522fb4697ce531154b5 MD5 · raw file

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