[MLton-commit] r6054
Vesa Karvonen
vesak at mlton.org
Fri Sep 28 03:20:52 PDT 2007
An experimental implementation of generic "shrinking".
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
A mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-28 10:20:49 UTC (rev 6054)
@@ -31,6 +31,7 @@
../../../public/value/pretty.sig
../../../public/value/reduce.sig
../../../public/value/seq.sig
+ ../../../public/value/shrink.sig
../../../public/value/size.sig
../../../public/value/some.sig
../../../public/value/transform.sig
@@ -61,6 +62,7 @@
../../value/pretty.sml
../../value/reduce.sml
../../value/seq.sml
+ ../../value/shrink.sml
../../value/size.sml
../../value/some.sml
../../value/transform.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,163 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithShrink (Arg : WITH_SHRINK_DOM) : SHRINK_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ type e = Univ.t List.t
+ datatype 'a t =
+ IN of {kids : Unit.t Ref.t * e * 'a -> e,
+ shrink : 'a -> 'a List.t}
+
+ fun iso' (IN {kids, shrink}) (a2b, b2a) =
+ IN {kids = fn (i, e, a) => kids (i, e, a2b a),
+ shrink = map b2a o shrink o a2b}
+
+ fun list' (IN {kids, shrink}) = let
+ fun shrinkL [] = []
+ | shrinkL (x::xs) =
+ [xs] @
+ map (fn x => x::xs) (shrink x) @
+ map (fn xs => x::xs) (shrinkL xs)
+ in
+ IN {kids = fn (i, e, xs) => foldl (fn (x, e) => kids (i, e, x)) e xs,
+ shrink = shrinkL}
+ end
+
+ val none =
+ IN {kids = fn (_, e, _) => e,
+ shrink = fn _ => []}
+
+ structure ShrinkRep = LayerRep
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
+
+ open ShrinkRep.This
+
+ fun sortUniq aT = let
+ val sizeOf = Arg.sizeOf aT
+ val ord = Arg.ord aT
+ fun uniq xs = let
+ fun lp (ys, xs) =
+ case xs
+ of [] => ys
+ | [(_ & x)] => x::ys
+ | (s1 & x1)::(s2 & x2)::xs =>
+ if s1 = s2 andalso EQUAL = ord (x1, x2)
+ then lp (ys, (s2 & x2)::xs)
+ else lp (x1::ys, (s2 & x2)::xs)
+ in
+ rev (lp ([], xs))
+ end
+ in
+ uniq o
+ List.sort (Cmp.*` (Int.compare, ord)) o
+ map (fn x => sizeOf x & x)
+ end
+
+ fun shrink aT =
+ case getT aT
+ of IN {shrink, ...} => sortUniq aT o shrink
+
+ fun shrinkFix aT = let (* XXX suboptimal *)
+ val shrink = shrink aT
+ val sortUniq = sortUniq aT
+ fun lp (toShrink, shrunken) = let
+ val shrunken = sortUniq (toShrink @ shrunken)
+ val toShrink = List.concatMap shrink toShrink
+ in
+ if null toShrink then shrunken else lp (toShrink, shrunken)
+ end
+ in
+ fn x => lp (shrink x, [])
+ end
+
+ structure Open = LayerDepCases
+ (fun iso aT = iso' (getT aT)
+ fun isoProduct aP = iso' (getP aP)
+ fun isoSum aS = iso' (getS aS)
+
+ fun op *` (aP, bP) = let
+ val IN aS = getP aP
+ val IN bS = getP bP
+ in
+ IN {kids = fn (i, e, a & b) => #kids bS (i, #kids aS (i, e, a), b),
+ shrink = fn a & b =>
+ map (fn a => a & b) (#shrink aS a) @
+ map (fn b => a & b) (#shrink bS b)}
+ end
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
+
+ fun op +` (aS, bS) = let
+ val IN aS = getS aS
+ val IN bS = getS bS
+ in
+ IN {kids = fn (i, e, INL a) => #kids aS (i, e, a)
+ | (i, e, INR b) => #kids bS (i, e, b),
+ shrink = fn INL a => map INL (#shrink aS a)
+ | INR b => map INR (#shrink bS b)}
+ end
+ val unit = none
+ fun C0 _ = unit
+ fun C1 _ = getT
+ val data = getS
+
+ fun Y ? = Tie.pure (fn () => let
+ val i = ref ()
+ val (to, from) = Univ.Iso.new ()
+ val r = ref (raising Fix.Fix)
+ in
+ (IN {kids = fn (i', e, x) => if i = i' then to x :: e else e,
+ shrink = fn x => !r x},
+ fn IN {kids, shrink} => let
+ fun shrinkT x = let
+ val ks = map from (kids (i, [], x))
+ in
+ ks @ shrink x
+ end
+ in
+ r := shrinkT
+ ; IN {kids = kids, shrink = shrinkT}
+ end)
+ end) ?
+
+ fun op --> _ = none
+
+ val exn = none
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun array _ = none
+ fun list aT = list' (getT aT)
+ fun vector aT = iso' (list aT) Vector.isoList
+
+ fun refc _ = none
+
+ val fixedInt = none
+ val largeInt = none
+
+ val largeReal = none
+ val largeWord = none
+
+ val bool = none
+ val char = none
+ val int = none
+ val real = none
+ val string = iso' (list' char) String.isoList
+ val word = none
+
+ val word8 = none
+ val word32 = none
+ val word64 = none
+
+ open Arg ShrinkRep)
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-28 10:20:49 UTC (rev 6054)
@@ -124,6 +124,9 @@
public/value/size.sig
detail/value/size.sml
+ public/value/shrink.sig
+ detail/value/shrink.sml
+
public/value/transform.sig
detail/value/transform.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -167,6 +167,10 @@
signature SEQ = SEQ and SEQ_CASES = SEQ_CASES and WITH_SEQ_DOM = WITH_SEQ_DOM
functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = WithSeq (Arg)
+signature SHRINK = SHRINK and SHRINK_CASES = SHRINK_CASES
+ and WITH_SHRINK_DOM = WITH_SHRINK_DOM
+functor WithShrink (Arg : WITH_SHRINK_DOM) : SHRINK_CASES = WithShrink (Arg)
+
signature SIZE = SIZE and SIZE_CASES = SIZE_CASES
and WITH_SIZE_DOM = WITH_SIZE_DOM
functor WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = WithSize (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,46 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a generic shrinking function.
+ *
+ * The basic idea is to "shrink" a given value by producing a list of
+ * maximal proper (or strict) subvalues (or subsets) of the given value.
+ * For example, given a list of booleans, calling {shrink} on the list
+ * would produce a list of lists of booleans where each list of booleans
+ * is the same as the given list except that it omits one element of the
+ * given list.
+ *
+ * The main application of shrinking is randomized testing.
+ *)
+signature SHRINK = sig
+ structure ShrinkRep : OPEN_REP
+
+ val shrink : ('a, 'x) ShrinkRep.t -> 'a -> 'a List.t
+ (** Extracts the single-layer shrinking function. *)
+
+ val shrinkFix : ('a, 'x) ShrinkRep.t -> 'a -> 'a List.t
+ (**
+ * Shrinks the given value to a fixpoint.
+ *
+ * WARNING: This function is impractical for most purposes, because the
+ * size of the output grows extremely rapidly depending on the type and
+ * size of the input. Frankly, this is mostly provided for playing
+ * with in a REPL and might be removed in the future.
+ *)
+end
+
+signature SHRINK_CASES = sig
+ structure Open : OPEN_CASES
+ include SHRINK
+ sharing Open.Rep = ShrinkRep
+end
+
+signature WITH_SHRINK_DOM = sig
+ structure Open : OPEN_CASES
+ include ORD SIZE
+ sharing Open.Rep = OrdRep = SizeRep
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,16 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature Generic = sig
+ include Generic SHRINK
+end
+
+structure Generic : Generic = struct
+ structure Open = WithShrink
+ (open Generic
+ structure OrdRep = Open.Rep and SizeRep = Open.Rep)
+ open Generic Open
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list