[MLton-commit] r6055
Vesa Karvonen
vesak at mlton.org
Fri Sep 28 04:17:54 PDT 2007
Simple shrinking based counterexample minimization.
----------------------------------------------------------------------
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/detail/unit-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb
U mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-28 11:17:53 UTC (rev 6055)
@@ -9,10 +9,19 @@
(*
* We assume here that {Eq} and {Pretty} have already been provided. The
* {Arbitrary} generic is rather specific to randomized testing and has
- * little use otherwise. The {Size} generic is probably also not used
- * much outside testing.
+ * probably little use otherwise. The same goes for {Shrink}. The {Size}
+ * generic is probably also not used much outside testing.
*)
+signature Generic = sig include Generic ARBITRARY end
+structure Generic : Generic = struct
+ structure Open = WithArbitrary
+ (open Generic
+ structure HashRep = Open.Rep and TypeInfoRep = Open.Rep
+ structure RandomGen = RanQD1Gen)
+ open Generic Open
+end
+
signature Generic = sig include Generic SIZE end
structure Generic : Generic = struct
structure Open = WithSize
@@ -21,12 +30,11 @@
open Generic Open
end
-signature Generic = sig include Generic ARBITRARY end
+signature Generic = sig include Generic SHRINK end
structure Generic : Generic = struct
- structure Open = WithArbitrary
+ structure Open = WithShrink
(open Generic
- structure HashRep = Open.Rep and TypeInfoRep = Open.Rep
- structure RandomGen = RanQD1Gen)
+ structure OrdRep = Open.Rep and SizeRep = Open.Rep)
open Generic Open
end
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-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-28 11:17:53 UTC (rev 6055)
@@ -20,7 +20,6 @@
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
@@ -122,8 +121,8 @@
fun testRaises exnPr th = test (fn () => thatRaises exnPr th)
fun testFails th = test (fn () => thatFails th)
- datatype result =
- BUG of Int.t * Prettier.t
+ datatype 'a result =
+ BUG of 'a * Prettier.t
| OK
| SKIP
@@ -145,26 +144,25 @@
exception Skip
fun allParam {size, maxPass, maxSkip} t ef = let
- fun genTest passN = let
- val v = RandomGen.generate (size passN) (nextRNG ()) (arbitrary t)
+ fun test v =
+ (ef v : Unit.t ; OK)
+ handle Skip => SKIP
+ | Failure d => BUG (v, named t "with" v <$> d)
+ | e => BUG (v, named t "with" v <$> namedExn "raised" e)
+
+ fun genTest passN =
+ test (RandomGen.generate (size passN) (nextRNG ()) (arbitrary t))
+
+ fun minimize (v, ms) = let
+ fun lp [] = failure ms
+ | lp (v::vs) =
+ case test v
+ of BUG (v, ms) => minimize (v, ms)
+ | _ => lp vs
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)
+ lp (shrink t v)
end
- 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 find (passN, skipN) =
if maxPass <= passN then
()
@@ -177,8 +175,8 @@
find (passN, skipN + 1)
| OK =>
find (passN + 1, skipN)
- | BUG (sz, ms) =>
- minimize (size passN, sz, sz, ms)
+ | BUG (v, ms) =>
+ minimize (v, ms)
in
find (0, 0)
end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml 2007-09-28 11:17:53 UTC (rev 6055)
@@ -7,4 +7,5 @@
structure UnitTest = MkUnitTest
(open Generic
structure ArbitraryRep = Open.Rep and EqRep = Open.Rep
- and PrettyRep = Open.Rep and SizeRep = Open.Rep)
+ and PrettyRep = Open.Rep and ShrinkRep = Open.Rep
+ and SizeRep = Open.Rep)
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb 2007-09-28 11:17:53 UTC (rev 6055)
@@ -12,8 +12,9 @@
lib.mlb
(* Order matters: *)
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
$(MLTON_LIB)/com/ssh/generic/unstable/with/size.sml
- $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/shrink.sml
$(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
detail/unit-test.sml
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-28 11:17:53 UTC (rev 6055)
@@ -12,5 +12,6 @@
include ARBITRARY sharing Open.Rep = ArbitraryRep
include EQ sharing Open.Rep = EqRep
include PRETTY sharing Open.Rep = PrettyRep
+ include SHRINK sharing Open.Rep = ShrinkRep
include SIZE sharing Open.Rep = SizeRep
end
More information about the MLton-commit
mailing list