[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