[MLton-commit] r6051
Vesa Karvonen
vesak at mlton.org
Thu Sep 27 03:49:10 PDT 2007
Redesigned the unit test framework and random testing interface in
particular.
The old random testing interface was largely a copy of QuickCheck. The
main difference is that there is no separate concept of a "property" or
"law". A test, whether randomized or not, is an effectful procedure that
raises an exception upon failure. In general, this reduces or eliminates
differences between randomized and non-randomized tests. A particular
benefit of this approach is that the same assertion procedures can be used
in both randomized and non-randomized tests --- there is no need to
provide two sets of assertion procedures.
Another notable difference compared to the old design is that data
collection, for debugging randomized tests, is no longer an integral part
of the framework. In the original QuickCheck design, data collection is
an integral part of the framework, because all data must be passed through
the property combinators. In SML, we can instead use side-effects to
avoid having to bundle data collection with the framework. This
simplifies the implementation considerably.
The main disadvantage of the new design seems to be a small increase in
verbosity (an extra thunk in some cases and more work to collect
statistics).
There is also no longer need to reveal that random generators are
functions.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
U mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
U mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -10,27 +10,27 @@
open Generic UnitTest
- fun chkSeq t =
- (chk o all t)
- (fn x => let
- val p = pickle t x
- in
- that (seq t (x, unpickle t p))
- end)
+ fun thatSeq t args =
+ if seq t (#actual args, #expect args) then () else thatEq t args
+ fun thatPU t x = let
+ val p = pickle t x
+ in
+ thatSeq t {expect = x, actual = unpickle t p}
+ end
+
+ fun testAllSeq t =
+ testAll t (thatPU t)
+
fun testSeq t x =
- test (fn () => let
- val p = pickle t x
- in
- verifyTrue (seq t (x, unpickle t p))
- end)
+ test (fn () => thatPU t x)
fun testTypeMismatch t u =
test (fn () => let
val p = pickle t (some t)
in
- verifyFailsWith
- (fn Pickle.TypeMismatch => true | _ => false)
+ thatRaises'
+ (fn Pickle.TypeMismatch => ())
(fn () => unpickle u p)
end)
in
@@ -38,11 +38,11 @@
unitTests
(title "Generic.Pickle")
- (chkSeq (vector (option (list real))))
- (chkSeq (tuple2 (fixedInt, largeInt)))
- (chkSeq (largeReal &` largeWord))
- (chkSeq (tuple3 (word8, word32, word64)))
- (chkSeq (bool &` char &` int &` real &` string &` word))
+ (testAllSeq (vector (option (list real))))
+ (testAllSeq (tuple2 (fixedInt, largeInt)))
+ (testAllSeq (largeReal &` largeWord))
+ (testAllSeq (tuple3 (word8, word32, word64)))
+ (testAllSeq (bool &` char &` int &` real &` string &` word))
(title "Generic.Pickle.Cyclic")
@@ -52,8 +52,8 @@
(title "Generic.Pickle.TypeMismatch")
(testTypeMismatch int word)
- (testTypeMismatch (list char) (vector char))
- (testTypeMismatch (array real) (option real))
+ (testTypeMismatch (list char) (vector word8))
+ (testTypeMismatch (array real) (option largeReal))
$
end
Modified: mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig
===================================================================
--- mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,8 +12,7 @@
signature RANDOM_GEN = sig
structure RNG : RNG
- type 'a dom and 'a cod
- type 'a t = 'a dom -> 'a cod
+ type 'a t
val generate : Int.t -> RNG.t -> 'a t -> 'a
@@ -39,7 +38,7 @@
val inRange : ('b Sq.t -> 'b t) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a t
- val intInRange : Int.t Sq.t -> Int.t t
+ val intInRange : Int.t Sq.t -> Int.t t
val realInRange : Real.t Sq.t -> Real.t t
val wordInRange : Word.t Sq.t -> Word.t t
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -4,6 +4,8 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+(* This whole file is a SML/NJ workaround. *)
+
(*
* We assume here that {Eq} and {Pretty} have already been provided. The
* {Arbitrary} generic is rather specific to randomized testing and has
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,97 +12,49 @@
struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix <^> <\ >| &
+ infix <$> <^> <\ >| &
infixr @` |<
(* SML/NJ workaround --> *)
- structure G=Arg.RandomGen and I=Int
+ open Arg Prettier
- structure Rep = Arg.Open.Rep
+ structure Rep = Open.Rep
+ fun sizeOf t v = Arg.sizeOf t v handle _ => 0
+ fun named t n v = group (nest 2 (str n <$> pretty t v))
+ val strs = str o concat
local
- open Arg
+ open Maybe
+ val I = Int.fromString
+ val cols = Monad.sum [S"-w"@`I, L"--width"@`I, E"COLUMNS"@`I, `70]
in
- val arbitrary = arbitrary
- val bool = bool
- val eq = eq
- val exn = exn
- val pretty = pretty
- val show = show
- fun sizeOf t v = Arg.sizeOf t v handle _ => 0
+ val println = println (get cols)
end
- local
- open Prettier
- in
- val indent = nest 2 o sep
- fun named t n v = str n <^> nest 2 (line <^> pretty t v)
- val comma = comma
- val dot = dot
- val group = group
- val op <^> = op <^>
+ val i2s = Int.toString
- local
- open Maybe
- val I = I.fromString
- val cols = Monad.sum [S"-w"@`I, L"--width"@`I, E"COLUMNS"@`I, `70]
- in
- val println = println (get cols)
- end
-
- val punctuate = punctuate
- val str = str
- end
-
datatype t =
IN of {title : String.t Option.t,
- idx : Int.t,
- size : Int.t UnOp.t,
- passM : Int.t,
- skipM : Int.t}
+ idx : Int.t}
type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
exception Failure of Prettier.t
- fun failure ? = Exn.throw (Failure ?)
+ fun failure d = raise Failure d
val defaultCfg =
IN {title = NONE,
- idx = 1,
- size = fn n => n div 2 + 3,
- passM = 100,
- skipM = 200}
+ idx = 1}
- local
- val ~ = (fn {title=a, idx=b, size=c, passM=d, skipM=e} => a&b&c&d&e,
- fn a&b&c&d&e => {title=a, idx=b, size=c, passM=d, skipM=e})
- open FRU
- in
- val U = U
- fun updCfg ? = fruData (fn IN ? => ?, IN) A5 $ ~ ~ ?
- end
-
val succeeded = ref 0
val failed = ref 0
- val i2s = I.toString
-
fun inc r = r := !r + 1
- fun runTest safeTest =
- Fold.mapSt (fn cfg as IN {idx, ...} =>
- (inc (if safeTest cfg then succeeded else failed)
- ; updCfg (U#idx (idx + 1)) $ cfg))
+ val printlnStrs = println o group o strs
- fun header (IN {title, idx, ...}) =
- case title
- of NONE => "An untitled test"
- | SOME t => concat [i2s idx, ". ", t, " test"]
-
(* We assume here that we're the first call to atExit so that it
* is (relatively) safe to call terminate in our atExit effect.
*)
-
- val printlnStrs = println o group o str o concat
val () =
OS.Process.atExit
(fn () =>
@@ -114,185 +66,150 @@
i2s (!failed), " failed."]
; OS.Process.terminate OS.Process.failure))
- (* TEST SPECIFICATION INTERFACE *)
+ fun namedExn label e =
+ named exn label e <^> dot <$>
+ (case Exn.history e
+ of [] => str "No exception history available"
+ | hs => nest 2 (sep (str "Exception history:" ::
+ punctuate comma (map str hs))))
fun unitTests ? = Fold.wrap (defaultCfg, ignore) ?
- fun title title = Fold.mapSt (updCfg (U #idx 1) (U #title (SOME title)) $)
+ fun title title = Fold.mapSt (const (IN {title = SOME title, idx = 1}))
- (* AD HOC TESTING HELPERS *)
-
- fun verifyEq t {actual, expect} =
+ fun thatEq t {actual, expect} =
if eq t (actual, expect) then ()
- else failure (indent [str "Equality test failed:",
- named t "expected" expect <^> comma,
- named t "but got" actual])
+ else failure (nest 2 (sep [str "equality test failed:",
+ named t "expected" expect <^> comma,
+ named t "but got" actual]))
- fun verifyTrue b = verifyEq bool {expect = true, actual = b}
- fun verifyFalse b = verifyEq bool {expect = false, actual = b}
+ fun that b = thatEq bool {expect = true, actual = b}
+ fun thatNot b = thatEq bool {expect = false, actual = b}
- fun verifyFailsWith ePr th =
+ fun thatRaises exnPr th =
try (th,
- fn _ => failure (str "Test didn't raise an exception as expected"),
- fn e => if ePr e then ()
- else failure o group |<
- named exn "Test raised an unexpected exception" e)
+ fn _ => failure (str "didn't get an exception as expected"),
+ fn e => if exnPr e then ()
+ else failure (namedExn "got an unexpected exception" e))
+ fun thatRaises' exnEf =
+ thatRaises (fn e => (exnEf e : Unit.t ; true) handle Match => false)
+ fun thatFails ? = thatRaises (const true) ?
- fun verifyFails ? = verifyFailsWith (const true) ?
- fun verifyRaises e = verifyFailsWith (e <\ eq exn)
-
(* TEST REGISTRATION INTERFACE *)
- fun history e =
- case Exn.history e
- of [] => str "No exception history available"
- | hs => indent (map str ("Exception history:"::hs))
-
fun test body =
- runTest
- (fn cfg =>
- try (body,
- fn _ =>
- (printlnStrs [header cfg, " succeeded."]
- ; true),
- fn e =>
- ((println o indent)
- [str (header cfg ^ " failed."),
- case e
- of Failure doc => doc <^> dot
- | _ => indent [str "Unhandled exception",
- str (Exn.message e) <^> dot],
- history e <^> dot]
- ; false)))
+ Fold.mapSt
+ (fn IN {title, idx} =>
+ (printlnStrs (case title
+ of NONE => ["An untitled test"]
+ | SOME t => [i2s idx, ". ", t, " test"])
+ ; try (body,
+ fn () =>
+ inc succeeded,
+ fn e =>
+ (inc failed
+ ; println
+ (indent 2
+ (txt "FAILED:" <$>
+ indent 2
+ (case e
+ of Failure d => d
+ | _ => namedExn "with exception" e) <^> dot))))
+ ; IN {title = title, idx = idx + 1}))
- fun testEq t th = test (verifyEq t o th)
+ fun testEq t th = test (thatEq t o th)
- fun testTrue th = test (verifyTrue o th)
- fun testFalse th = test (verifyFalse o th)
+ fun testRaises' exnEf th = test (fn () => thatRaises' exnEf th)
+ fun testRaises exnPr th = test (fn () => thatRaises exnPr th)
+ fun testFails th = test (fn () => thatFails th)
- fun testFailsWith ep th = test (fn () => verifyFailsWith ep th)
- fun testFails th = test (fn () => verifyFails th)
- fun testRaises e th = test (fn () => verifyRaises e th)
-
- (* RANDOM TESTING INTERFACE *)
-
datatype result =
- BUG of Int.t * Prettier.t List.t
- | OK of String.t List.t
+ BUG of Int.t * Prettier.t
+ | OK
| SKIP
- type law = result G.t
-
local
- fun mk field value = Fold.mapSt (updCfg (U field value) $)
+ open RandomGen.RNG
+ val rng =
+ ref (make (Seed.fromWord let
+ open Maybe
+ val W = Word.fromString
+ in
+ getOpt (get (Monad.sum [S"-s"@`W, L"--seed"@`W,
+ mk RandomDev.seed ()]),
+ 0w0)
+ end))
in
- fun sizeFn ? = mk #size ?
- fun maxPass ? = mk #passM ?
- fun maxSkip ? = mk #skipM ?
+ fun nextRNG () = !rng before Ref.modify next rng
end
- val rng = ref (G.RNG.make (G.RNG.Seed.fromWord let
- open Maybe
- val W = Word.fromString
- in
- getOpt (get (Monad.sum [S"-s"@`W, L"--seed"@`W,
- mk RandomDev.seed ()]),
- 0w0)
- end))
+ exception Skip
- fun sort ? = SortedList.stableSort #n ?
+ fun allParam {size, maxPass, maxSkip} t ef = let
+ fun genTest passN = let
+ val v = RandomGen.generate (size passN) (nextRNG ()) (arbitrary t)
+ in
+ (ef v : Unit.t ; OK)
+ handle Skip => SKIP
+ | Failure d => BUG (sizeOf t v, named t "with" v <$> d)
+ | e => BUG (sizeOf t v,
+ named t "with" v <$> namedExn "raised" e)
+ end
- fun table n =
- punctuate comma o
- map (fn (n, m) => str (concat [i2s n, "% ", m])) o
- sort (I.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
- map (Pair.map (fn l => Int.quot (100 * length l, n), hd) o Sq.mk) o
- List.divideByEq op =
+ fun minimize (genSz, origSz, minSz, minMsg) =
+ if genSz < 0
+ then failure minMsg
+ else case genTest genSz
+ of BUG (sz, msg) =>
+ if sz < minSz
+ then minimize (genSz-1, origSz, sz, msg)
+ else minimize (genSz-1, origSz, minSz, minMsg)
+ | _ => minimize (genSz-1, origSz, minSz, minMsg)
- fun chk prop =
- runTest
- (fn cfg as IN {size, passM, skipM, ...} => let
- fun done (msg, passN, tags) =
- ((println o indent)
- ((str o concat)
- [header cfg, ":\n", msg, " ", i2s passN,
- " random cases passed."]::
- (if null tags then
- []
- else
- [indent (str "Statistics:" ::
- table passN tags) <^> dot]))
- ; true)
+ fun find (passN, skipN) =
+ if maxPass <= passN then
+ ()
+ else if maxSkip <= skipN then
+ println (indent 2 (strs ["Arguments exhausted after ", i2s passN,
+ " tests."]))
+ else
+ case genTest (size passN)
+ of SKIP =>
+ find (passN, skipN + 1)
+ | OK =>
+ find (passN + 1, skipN)
+ | BUG (sz, ms) =>
+ minimize (size passN, sz, sz, ms)
+ in
+ find (0, 0)
+ end
- fun gen passN =
- G.generate (size passN)
- (!rng before Ref.modify G.RNG.next rng)
- prop
+ fun all t =
+ allParam {size = fn n => n div 2 + 3,
+ maxPass = 100,
+ maxSkip = 100} t
- fun minimize (genSz, origSz, minSz, minMsgs) =
- if genSz < 0
- then (println |< indent
- [str (header cfg ^ " failed."),
- indent (str "Falsifiable:"::minMsgs) <^> dot,
- (str o concat)
- (if minSz < origSz
- then ["Reduced counterexample from size ",
- Int.toString origSz, " to size ",
- Int.toString minSz, "."]
- else ["Couldn't find a counterexample smaller\
- \ than size ", Int.toString origSz, "."])]
- ; false)
- else
- case gen genSz
- of BUG (sz, msgs) =>
- if sz < minSz
- then minimize (genSz-1, origSz, sz, msgs)
- else minimize (genSz-1, origSz, minSz, minMsgs)
- | _ =>
- minimize (genSz-1, origSz, minSz, minMsgs)
+ fun testAll t ef = test (fn () => all t ef)
- fun find (passN, skipN, allTags) =
- if passM <= passN then
- done ("OK,", passN, allTags)
- else if skipM <= skipN then
- done ("Arguments exhausted after", passN, allTags)
- else
- case gen (size passN)
- of SKIP =>
- find (passN, skipN + 1, allTags)
- | OK tags =>
- find (passN + 1, skipN, List.revAppend (tags, allTags))
- | BUG (sz, msgs) =>
- minimize (size passN, sz, sz, msgs)
- in
- find (0, 0, [])
- end)
+ fun skip () = raise Skip
- fun all t toProp =
- G.>>= (arbitrary t,
- fn v => fn ? =>
- (G.>>= (toProp v,
- fn BUG (sz, msgs) =>
- G.return (BUG (sz + sizeOf t v,
- named t "with" v :: msgs))
- | p =>
- G.return p) ?
- handle e =>
- G.return (BUG (sizeOf t v,
- [named t "with" v,
- named exn "raised" e <^> dot,
- history e])) ?))
+ fun table t = let
+ val n = length t
+ in
+ punctuate comma o
+ map (fn (n, m) => str (concat [i2s n, "% ", m])) o
+ List.sort (Int.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
+ map (Pair.map (fn l => Int.quot (100 * length l, n), hd) o Sq.mk) o
+ List.divideByEq op = |< List.map (render NONE) t
+ end
- fun that b = G.return (if b then OK [] else BUG (0, []))
- val skip = G.return SKIP
-
- fun classify tOpt =
- G.Monad.map (fn r =>
- case tOpt & r
- of SOME t & OK ts => OK (t::ts)
- | _ => r)
- fun trivial b = classify (if b then SOME "trivial" else NONE)
-
- fun collect t v =
- G.Monad.map (fn OK ts => OK (show t v::ts)
- | res => res)
+ type table = Prettier.t List.t Ref.t
+ fun withFreq tblEf = let
+ val tbl = ref []
+ in
+ tblEf tbl : Unit.t
+ ; println (indent 2 (nest 2 (sep (str "Statistics:" :: table (!tbl)))) <^>
+ dot)
+ end
+ fun collect t tbl x =
+ List.push tbl (pretty t x)
end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,18 +12,19 @@
val () = let
open Generic UnitTest
- fun assoc op + t =
+ fun thatAssoc op + t =
all (t &` t &` t)
(fn x & y & z =>
- that (eq t ((x + y) + z, x + (y + z))))
+ thatEq t {actual = (x + y) + z,
+ expect = x + (y + z)})
in
unitTests
(title "Assoc")
- (chk (assoc op + word))
+ (test (fn () => thatAssoc op + word))
(* This law holds. *)
- (chk (assoc op + real))
+ (test (fn () => thatAssoc op + real))
(* This law does not hold. *)
$
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -37,29 +37,29 @@
unitTests
(title "Reverse")
- (chk (all int
- (fn x =>
- that (rev [x] = [x]))))
+ (testAll int
+ (fn x =>
+ that (rev [x] = [x])))
(* Read the above as:
*
- * "check for all integers x that the reverse of the singleton
+ * "test for all integers x that the reverse of the singleton
* list x equals the singleton list x"
*
- * (Of course, in reality, the property is only checked for a small
- * finite number of random integers at a time.)
+ * Of course, in reality, the property is only checked for a small
+ * finite number of random integers at a time.
*
- * In contrast to QuickCheck/Haskell, one must explicitly lift
- * boolean values to properties using {that}.
+ * In contrast to QuickCheck, properties are explicitly checked
+ * using {that} and other assertion procedures.
*)
- (chk (all (sq (list int))
- (fn (xs, ys) =>
- that (rev (xs @ ys) = rev ys @ rev xs))))
+ (testAll (sq (list int))
+ (fn (xs, ys) =>
+ that (rev (xs @ ys) = rev ys @ rev xs)))
- (chk (all (list int)
- (fn xs =>
- that (rev (rev xs) = xs))))
+ (testAll (list int)
+ (fn xs =>
+ that (rev (rev xs) = xs)))
(title "Functions")
@@ -68,10 +68,10 @@
fun (f === g) x = that (f x = g x)
(* An approximation of extensional equality for functions. *)
in
- chk (all (case unOp int of t => t &` t &` t)
- (fn f & g & h =>
- all int
- (f o (g o h) === (f o g) o h)))
+ testAll (case unOp int of t => t &` t &` t)
+ (fn f & g & h =>
+ all int
+ (f o (g o h) === (f o g) o h))
(* Note that one can (of course) also write local auxiliary
* definitions inside let -expressions.
@@ -80,46 +80,53 @@
(title "Conditional laws")
- (chk (all (sq int)
- (fn (x, y) =>
- if x <= y
- then that (Int.max (x, y) = y)
- else skip)))
+ (testAll (sq int)
+ (fn (x, y) =>
+ if x <= y
+ then that (Int.max (x, y) = y)
+ else skip ()))
(* Read the above as:
*
- * "check for all integer pairs (x, y) that
+ * "test for all integer pairs (x, y) that
* if x <= y then max (x, y) = y"
*
- * In contrast to QuickCheck/Haskell, conditional properties are
- * specified using conditionals and {skip} rather than using an
- * implication operator.
+ * In contrast to QuickCheck, conditional properties are specified
+ * using conditionals and {skip ()} rather than using an implication
+ * operator.
*)
(title "Monitoring test data")
- (chk (all (int &` list int)
- (fn x & xs =>
- if isSorted xs
- then (trivial (null xs))
- (that (isSorted (insert x xs)))
- else skip)))
+ (test (fn () =>
+ withFreq (fn tbl =>
+ all (int &` list int)
+ (fn x & xs =>
+ if isSorted xs
+ then (collect int tbl (length xs)
+ ; that (isSorted (insert x xs)))
+ else skip ()))))
- (chk (all (int &` list int)
- (fn x & xs =>
- if isSorted xs
- then (collect int (length xs))
- (that (isSorted (insert x xs)))
- else skip)))
+ (* Above we collect the generated sorted lists and print a table of
+ * the frequencies of their lengths using {withFreq} and {collect}.
+ *
+ * In contrast to QuickCheck, data collection is not bolted into the
+ * test framework.
+ *)
- (chk (all (int &` sortedList)
- (fn x & xs =>
- that o isSorted |< insert x xs)))
+ (test (fn () =>
+ withFreq (fn tbl =>
+ all (int &` sortedList)
+ (fn x & xs =>
+ (collect int tbl (length xs)
+ ; that (isSorted (insert x xs)))))))
(* Above we use a custom test data generator for sorted (or ordered)
- * lists. In contrast to QuickCheck/Haskell, the custom data
- * generator needs to be injected into a type-index (recall the use
- * of {withGen} in the implementation of {sortedList} above).
+ * lists.
+ *
+ * In contrast to QuickCheck, the custom data generator is
+ * explicitly injected into a type representation. Recall the use
+ * of {withGen} in the implementation of {sortedList} above.
*)
$
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 10:49:03 UTC (rev 6051)
@@ -25,140 +25,92 @@
val title : String.t -> 'a s
(** {title string} specifies the title for subsequent tests. *)
- (** === Test Registration Interface === *)
+ (** === Test Registration === *)
val test : Unit.t Effect.t -> 'a s
(**
- * Registers an ad hoc test. An ad hoc test should indicate failure by
- * raising an exception.
+ * Registers a test. A test is just an arbitrary unit effect that
+ * should indicate failure by raising an exception.
*)
val testEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Thunk.t -> 'b s
(** Tests that the expected and actual values are equal. *)
- val testTrue : Bool.t Thunk.t -> 'a s
- (** Tests that the thunk evaluates to {true}. *)
-
- val testFalse : Bool.t Thunk.t -> 'a s
- (** Tests that the thunk evaluates to {false}. *)
-
- val testFailsWith : Exn.t UnPr.t -> 'a Thunk.t -> 'b s
+ val testRaises' : Exn.t Effect.t -> 'a Thunk.t -> 'b s
+ val testRaises : Exn.t UnPr.t -> 'a Thunk.t -> 'b s
(** Tests that the thunk raises an exception satisfying the predicate. *)
val testFails : 'a Thunk.t -> 'b s
(** Tests that the thunk raises an exception. *)
- val testRaises : Exn.t -> 'a Thunk.t -> 'b s
- (**
- * Tests that the thunk raises an exception equal to the given one.
- * The exception constructor must be registered with {regExn}.
- *)
+ (** == Random Testing == *)
- (** == Random Testing Interface == *)
+ val testAll : ('a, 'x) Rep.t -> 'a Effect.t -> 'b s
+ (** {testAll ty body} is equivalent to {test (fn () => all ty body)}. *)
- val sizeFn : Int.t UnOp.t -> 'a s
+ val all : ('a, 'x) Rep.t -> 'a Effect.t Effect.t
(**
- * Sets the function to determine the "size" of generated random test
- * data. The argument to the function is the number of tests passed.
- * The default function is {fn n => n div 2 + 3}.
- *)
-
- val maxPass : Int.t -> 'a s
- (**
- * Sets the maximum number of passed random test cases to try per test.
- * The default is 100.
- *)
-
- val maxSkip : Int.t -> 'a s
- (**
- * Sets the maximum number of skipped random test cases to accept per
- * test. The default is 200. If a lot of tests are being skipped, you
- * should implement a better test data generator or a more
- * comprehensive law.
- *)
-
- type law
- (** The type of testable laws or properties. *)
-
- val chk : law -> 'b s
- (**
- * Tries to find counter examples to a given law by testing the law
- * with randomly generated cases.
- *)
-
- val all : ('a, 'x) Rep.t -> ('a -> law) -> law
- (**
- * Specifies that a law must hold for all values of type {'a}. For
- * example,
+ * Procedurally, tries to fault the given test effect by calling it
+ * with randomly generated data.
*
+ * Declaratively, specifies that a law must hold for all values of type
+ * {'a}. For example,
+ *
*> all int (fn x => that (x = x))
*
* specifies that all integers must be equal to themselves.
*)
- val that : Bool.t -> law
+ val skip : 'a Thunk.t
(**
- * Specifies a primitive boolean law. For example,
+ * Calling {skip ()} specifies that the premises of a conditional law
+ * aren't satisfied so the specific test case of the law should be
+ * ignored. For example,
*
- *> that (1 <= 2)
- *
- * specifies that {1} is less than or equal to {2}.
- *)
-
- val skip : law
- (**
- * Specifies that the premises of a conditional law aren't satisfied so
- * the specific test case of the law should be ignored. For example,
- *
*> all (sq int)
*> (fn (x, y) =>
*> if x <= y
*> then that (Int.max (x, y) = y)
- *> else skip)
+ *> else skip ())
*
* specifies that if {x <= y} then {Int.max (x, y) = y}.
+ *
+ * Skipping tests is inefficient. If a lot of tests are being skipped,
+ * you should implement a better test data generator or a more
+ * comprehensive law.
*)
- val classify : String.t Option.t -> law UnOp.t
- (**
- * Classifies cases of a law. The distribution of classified cases
- * will be logged.
- *)
+ (** == Collecting Statistics == *)
- val trivial : Bool.t -> law UnOp.t
- (** Convenience function to classify cases of a law as "trivial". *)
+ type table
+ val withFreq : table Effect.t Effect.t
+ val collect : ('a, 'x) Rep.t -> table -> 'a Effect.t
- val collect : ('a, 'x) Rep.t -> 'a -> law UnOp.t
+ (** == Assertions == *)
+
+ exception Failure of Prettier.t
(**
- * Classifies test cases by value of type {'a}. The distribution as
- * well as the (pretty printed) values will be logged.
+ * Exception for reporting prettier errors from tests. Unlike other
+ * exceptions, the unit test framework just prints the document
+ * contained by a {Failure} exception with a dot at the end.
*)
- (** == Ad Hoc Testing Helpers == *)
-
- exception Failure of Prettier.t
- (** Exception for reporting prettier errors. *)
-
- val verifyEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Effect.t
- (** Verifies that the expected and actual values are equal. *)
-
- val verifyTrue : Bool.t Effect.t
+ val that : Bool.t Effect.t
(** Verifies that the given value is {true}. *)
- val verifyFalse : Bool.t Effect.t
+ val thatNot : Bool.t Effect.t
(** Verifies that the given value is {false}. *)
- val verifyFailsWith : Exn.t UnPr.t -> 'a Thunk.t Effect.t
+ val thatEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Effect.t
+ (** Verifies that the expected and actual values are equal. *)
+
+ val thatRaises' : Exn.t Effect.t -> 'a Thunk.t Effect.t
+ val thatRaises : Exn.t UnPr.t -> 'a Thunk.t Effect.t
(**
* Verifies that the thunk fails with an exception satisfying the
* predicate.
*)
- val verifyFails : 'a Thunk.t Effect.t
+ val thatFails : 'a Thunk.t Effect.t
(** Verifies that the given thunk fails with an exception. *)
-
- val verifyRaises : Exn.t -> 'a Thunk.t Effect.t
- (**
- * Verifies that the thunk raises an exception equal to the given one.
- *)
end
More information about the MLton-commit
mailing list