mirror of
https://github.com/c-cube/moonpool.git
synced 2025-12-07 11:45:39 -05:00
add some property tests
This commit is contained in:
parent
7707a7c1ce
commit
4e112e1591
4 changed files with 53 additions and 2 deletions
|
|
@ -20,6 +20,7 @@
|
||||||
dune
|
dune
|
||||||
(either (>= 1.0))
|
(either (>= 1.0))
|
||||||
(trace :with-test)
|
(trace :with-test)
|
||||||
|
(qcheck-core (and :with-test (>= 0.19)))
|
||||||
(odoc :with-doc)
|
(odoc :with-doc)
|
||||||
(mdx
|
(mdx
|
||||||
(and
|
(and
|
||||||
|
|
|
||||||
|
|
@ -13,6 +13,7 @@ depends: [
|
||||||
"dune" {>= "3.0"}
|
"dune" {>= "3.0"}
|
||||||
"either" {>= "1.0"}
|
"either" {>= "1.0"}
|
||||||
"trace" {with-test}
|
"trace" {with-test}
|
||||||
|
"qcheck-core" {with-test & >= "0.19"}
|
||||||
"odoc" {with-doc}
|
"odoc" {with-doc}
|
||||||
"mdx" {>= "1.9.0" & with-test}
|
"mdx" {>= "1.9.0" & with-test}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
(tests
|
(tests
|
||||||
(names t_fib t_bench1 t_fib_rec t_futs1 t_tree_futs)
|
(names t_fib t_bench1 t_fib_rec t_futs1 t_tree_futs t_props)
|
||||||
(libraries moonpool
|
(libraries moonpool qcheck-core qcheck-core.runner
|
||||||
;tracy-client.trace
|
;tracy-client.trace
|
||||||
trace))
|
trace))
|
||||||
|
|
|
||||||
49
test/t_props.ml
Normal file
49
test/t_props.ml
Normal file
|
|
@ -0,0 +1,49 @@
|
||||||
|
module Q = QCheck
|
||||||
|
open Moonpool
|
||||||
|
|
||||||
|
let tests = ref []
|
||||||
|
let add_test t = tests := t :: !tests
|
||||||
|
|
||||||
|
(* main pool *)
|
||||||
|
let pool = Pool.create ~min:4 ~per_domain:1 ()
|
||||||
|
|
||||||
|
(* pool for future combinators *)
|
||||||
|
let pool_fut = Pool.create ~min:2 ()
|
||||||
|
|
||||||
|
module Fut2 = (val Fut.infix pool_fut)
|
||||||
|
|
||||||
|
let () =
|
||||||
|
add_test
|
||||||
|
@@ Q.Test.make ~name:"map then join_list"
|
||||||
|
Q.(small_list small_int)
|
||||||
|
(fun l ->
|
||||||
|
let l' = List.map (fun x -> Fut.spawn ~on:pool (fun () -> x + 1)) l in
|
||||||
|
let l' = Fut.join_list l' |> Fut.wait_block_exn in
|
||||||
|
if l' <> List.map succ l then Q.Test.fail_reportf "bad list";
|
||||||
|
true)
|
||||||
|
|
||||||
|
let () =
|
||||||
|
add_test
|
||||||
|
@@ Q.Test.make ~name:"map bind"
|
||||||
|
Q.(small_list small_int)
|
||||||
|
(fun l ->
|
||||||
|
let open Fut2 in
|
||||||
|
let l' =
|
||||||
|
l
|
||||||
|
|> List.map (fun x ->
|
||||||
|
let* x = Fut.spawn ~on:pool_fut (fun () -> x + 1) in
|
||||||
|
let* y = Fut.return (x - 1) in
|
||||||
|
let+ z = Fut.spawn ~on:pool_fut (fun () -> string_of_int y) in
|
||||||
|
z)
|
||||||
|
in
|
||||||
|
|
||||||
|
Fut.wait_list l' |> Fut.wait_block_exn;
|
||||||
|
|
||||||
|
let l_res = List.map Fut.get_or_fail_exn l' in
|
||||||
|
if l_res <> List.map string_of_int l then
|
||||||
|
Q.Test.fail_reportf "bad list: from %s, to %s"
|
||||||
|
Q.Print.(list int l)
|
||||||
|
Q.Print.(list string l_res);
|
||||||
|
true)
|
||||||
|
|
||||||
|
let () = QCheck_base_runner.run_tests_main !tests
|
||||||
Loading…
Add table
Reference in a new issue