[MLton-commit] r5726

Vesa Karvonen vesak at mlton.org
Wed Jul 4 03:19:16 PDT 2007


Initial commit of separate unit-test library.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/unit-test/
A   mltonlib/trunk/com/ssh/unit-test/unstable/
A   mltonlib/trunk/com/ssh/unit-test/unstable/Check.bgb
A   mltonlib/trunk/com/ssh/unit-test/unstable/Check.sh
A   mltonlib/trunk/com/ssh/unit-test/unstable/LICENSE
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/maybe.sml
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm
A   mltonlib/trunk/com/ssh/unit-test/unstable/detail/sorted-list.sml
A   mltonlib/trunk/com/ssh/unit-test/unstable/lib.cm
A   mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb
A   mltonlib/trunk/com/ssh/unit-test/unstable/public/
A   mltonlib/trunk/com/ssh/unit-test/unstable/public/export.sml
A   mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
A   mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig

----------------------------------------------------------------------


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable
___________________________________________________________________
Name: svn:ignore
   + generated


Added: mltonlib/trunk/com/ssh/unit-test/unstable/Check.bgb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/Check.bgb	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/Check.bgb	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,8 @@
+;; 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.
+
+(bg-build
+ :name  "Unit Test"
+ :shell "./Check.sh")

Added: mltonlib/trunk/com/ssh/unit-test/unstable/Check.sh
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/Check.sh	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/Check.sh	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,23 @@
+#!/bin/bash
+
+# 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.
+
+name=lib
+
+set -e
+set -x
+
+mkdir -p generated
+
+echo "SML_COMPILER mlton
+MLTON_LIB $(cd ../../../.. && pwd)" > generated/mlb-path-map
+
+mlton -mlb-path-map generated/mlb-path-map         \
+      -prefer-abs-paths true                       \
+      -stop tc                                     \
+      -show-def-use generated/$name.du             \
+      -show-basis generated/$name.basis            \
+      $name.mlb


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable/Check.sh
___________________________________________________________________
Name: svn:executable
   + *
Name: svn:eol-style
   + native

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/LICENSE (from rev 5602, mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE)

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml (from rev 5723, mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml	2007-07-04 09:22:44 UTC (rev 5723)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,71 @@
+(* 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.
+ *)
+
+(*
+ * Support for functional record update.
+ *
+ * See
+ *
+ *   http://mlton.org/FunctionalRecordUpdate
+ *
+ * for further information.
+ *)
+
+structure FRU = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   infix &
+   (* SML/NJ workaround --> *)
+
+   fun make ? = let
+      fun fin (m, u) =
+          fn iso : ('r1, 'p1) Iso.t =>
+             fn (_, p2r') : ('r2, 'p2) Iso.t =>
+                p2r' (m (Fn.map iso o u))
+   in
+      Fold.NSZ.wrap {none = fin, some = fin,
+                     zero = (const (), id)}
+   end ?
+
+   fun A ? =
+       Fold.NSZ.mapSt
+          {none = Pair.map (const id, const const),
+           some = Pair.map (fn m =>
+                               fn p =>
+                                  m (p o INL) & (p o INR),
+                            fn u =>
+                               fn INL p =>
+                                  (fn l & r => u p l & r)
+                                | INR v =>
+                                  (fn l & _ => l & v))} ?
+
+   (* 2^n *)
+   val A1 = A
+   fun A2 ? = pass ? A1 A1
+   fun A4 ? = pass ? A2 A2
+   fun A8 ? = pass ? A4 A4
+
+   (* 2^i + j where j < 2^i *)
+   fun A3  ? = pass ? A2 A1
+   fun A5  ? = pass ? A4 A1
+   fun A6  ? = pass ? A4 A2
+   fun A7  ? = pass ? A4 A3
+   fun A9  ? = pass ? A8 A1
+   fun A10 ? = pass ? A8 A2
+   fun A11 ? = pass ? A8 A3
+   fun A12 ? = pass ? A8 A4
+   fun A13 ? = pass ? A8 A5
+   fun A14 ? = pass ? A8 A6
+   fun A15 ? = pass ? A8 A7
+
+   fun updData iso u = Fold.wrap ((id, u), Fn.map iso o Pair.fst)
+   fun fruData iso = Fold.post (fn f => fn ~ => updData iso o f ~) make
+
+   fun upd ? = updData Iso.id ?
+   fun fru ? = fruData Iso.id ?
+
+   fun U s v = Fold.mapSt (fn (f, u) => (s u v o f, u))
+end

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/detail/maybe.sml (from rev 5723, mltonlib/trunk/com/ssh/misc-util/unstable/maybe.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/maybe.sml	2007-07-04 09:22:44 UTC (rev 5723)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/maybe.sml	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,63 @@
+(* 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.
+ *)
+
+(**
+ * A small combinator library for specifying queries.
+ *
+ * This is similar to the Maybe monad familiar from Haskell, but we can,
+ * of course, also perform effectful queries.  An example of an effectful
+ * query is {E} which queries the environment.
+ *)
+structure Maybe :> sig
+   type 'v t
+   include MONADP_CORE where type 'v monad = 'v t
+   structure Monad : MONADP where type 'v monad = 'v t
+   val ` : 'a -> 'a t
+   val liftBinFn : ('a * 'b -> 'c) -> 'a t * 'b t -> 'c t (* XXX move to MONAD *)
+   val get : 'a t -> 'a Option.t
+   val mk : ('k -> 'v Option.t) -> 'k -> 'v t
+   val E : String.t -> String.t t
+   val ^` : String.t t BinOp.t
+   val @` : 'a t * ('a -> 'b Option.t) -> 'b t
+   val O : String.t -> Unit.t t
+   val L : String.t -> String.t t
+   val S : String.t -> String.t t
+end = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   infix >>= <|> >>*
+   infixr |< @`
+   (* SML/NJ workaround --> *)
+
+   type 'v t = 'v Option.t Thunk.t
+   fun ` x = const (SOME x)
+   structure Monad =
+     MkMonadP
+       (type 'v monad = 'v t
+        val return = `
+        fun (aM >>= a2bM) () = case aM () of NONE => NONE | SOME a => a2bM a ()
+        fun zero () = NONE
+        fun (l <|> r) () = case l () of NONE => r () | r => r)
+   open Monad
+   fun liftBinFn f (aM, bM) = map f (aM >>* bM)
+   fun get q = q ()
+   fun mk f k () = f k
+   val E = mk OS.Process.getEnv
+   val op ^` = liftBinFn op ^
+   local
+      fun is s x = s = x
+      fun isE s = String.isPrefix (s^"=")
+      fun two f s = fn a::x::_ => SOME (f (s, a, x)) | _ => NONE
+      fun one f s = fn [] => NONE | x::_ => SOME (f (s, x))
+      val drop = flip List.dropWhile (CommandLine.arguments ())
+      fun arg p r e = mk (fn s => r e s o drop |< not o p s)
+   in
+      val L = arg isE one (fn (s, a) => String.extract (a, 1+size s, NONE))
+      val S = arg is two #3
+      val O = arg is one (const ())
+   end
+   fun aM @` from = aM >>= const o from
+end

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun (from rev 5723, mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml	2007-07-04 09:22:44 UTC (rev 5723)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,260 @@
+(* 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 MkUnitTest (Arg : MK_UNIT_TEST_DOM) :>
+   UNIT_TEST
+      where type ('a,     'x) Rep.t = ('a,     'x) Arg.Open.Rep.t
+      where type ('a,     'x) Rep.s = ('a,     'x) Arg.Open.Rep.s
+      where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Open.Rep.p =
+struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   infix <^> <\ >| &
+   infixr @` |<
+   (* SML/NJ workaround --> *)
+
+   structure G=Arg.RandomGen and I=Int
+
+   structure Rep = Arg.Open.Rep
+
+   local
+      open Arg
+   in
+      val arbitrary = arbitrary
+      val bool = bool
+      val eq = eq
+      val exn = exn
+      val layout = layout
+   end
+
+   local
+      open Prettier
+   in
+      val indent = nest 2 o sep
+      fun named t n v = str n <^> nest 2 (line <^> layout t v)
+      val comma = comma
+      val dot = dot
+      val group = group
+      val op <^> = op <^>
+      val pretty = pretty
+
+      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 TextIO.stdOut (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}
+   type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+
+   exception Failure of Prettier.t
+   fun failure ? = Exn.throw (Failure ?)
+
+   val defaultCfg =
+       IN {title = NONE,
+           idx   = 1,
+           size  = fn n => n div 2 + 3,
+           passM = 100,
+           skipM = 200}
+
+   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))
+
+   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 () =>
+              if 0 = !failed then
+                 printlnStrs ["All ", i2s (!succeeded), " tests succeeded."]
+              else
+                 (printlnStrs [i2s (!succeeded + !failed), " tests of which\n",
+                               i2s (!succeeded), " succeeded and\n",
+                               i2s (!failed), " failed."]
+                ; OS.Process.terminate OS.Process.failure))
+
+   (* TEST SPECIFICATION INTERFACE *)
+
+   fun unitTests ? = Fold.wrap (defaultCfg, ignore) ?
+   fun title title = Fold.mapSt (updCfg (U #idx 1) (U #title (SOME title)) $)
+
+   (* AD HOC TESTING HELPERS *)
+
+   fun verifyEq 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])
+
+   fun verifyTrue  b = verifyEq bool {expect = true,  actual = b}
+   fun verifyFalse b = verifyEq bool {expect = false, actual = b}
+
+   fun verifyFailsWith ePr 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)
+
+   fun verifyFails ? = verifyFailsWith (const true) ?
+   fun verifyRaises e = verifyFailsWith (e <\ eq exn)
+
+   (* TEST REGISTRATION INTERFACE *)
+
+   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],
+                           case Exn.history e of
+                              [] =>
+                              str "No exception history available."
+                            | hs => (indent o map str)
+                                       ("Exception history:"::hs)]
+                     ; false)))
+
+   fun testEq t th = test (verifyEq t o th)
+
+   fun testTrue  th = test (verifyTrue  o th)
+   fun testFalse th = test (verifyFalse o 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 *)
+
+   type law = (Bool.t Option.t * String.t List.t * Prettier.t List.t) G.t
+
+   local
+      fun mk field value = Fold.mapSt (updCfg (U field value) $)
+   in
+      fun sizeFn  ? = mk #size  ?
+      fun maxPass ? = mk #passM ?
+      fun maxSkip ? = mk #skipM ?
+   end
+
+   val rng = ref (G.RNG.make (G.RNG.Seed.fromWord (getOpt (RandomDev.seed (), 0w0))))
+
+   fun sort ? = SortedList.stableSort #n ?
+
+   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 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 lp passN skipN allTags =
+                  if passM <= passN then
+                     done "OK," passN allTags
+                  else if skipM <= skipN then
+                     done "Arguments exhausted after" passN allTags
+                  else
+                     case G.generate (size passN)
+                                     (!rng before Ref.modify G.RNG.next rng)
+                                     prop of
+                        (NONE, _, _) =>
+                        lp passN (skipN + 1) allTags
+                      | (SOME true, tags, _) =>
+                        lp (passN + 1) skipN (List.revAppend (tags, allTags))
+                      | (SOME false, _, msgs) =>
+                        ((println o indent)
+                            [str (header cfg ^ " failed."),
+                             indent (str "Falsifiable:"::msgs) <^> dot]
+                       ; false)
+           in
+              lp 0 0 []
+           end)
+
+   fun all t toProp =
+       G.>>= (arbitrary t,
+              fn v => fn ? =>
+                 (G.>>= (toProp v,
+                         fn (r as SOME false, ts, msgs) =>
+                            G.return (r, ts, named t "with" v :: msgs)
+                          | p =>
+                            G.return p) ?
+                  handle e =>
+                         G.return (SOME false, [],
+                                   [named t "with" v,
+                                    named exn "raised" e]) ?))
+
+   fun that b = G.return (SOME b, [], [])
+   val skip : law = G.return (NONE, [], [])
+
+   fun classify tOpt p =
+       G.Monad.map (fn p as (r, ts, msg) =>
+                       case tOpt & r of
+                          NONE & _ => p
+                        | _ & NONE => p
+                        | SOME t & _ => (r, t::ts, msg)) p
+   fun trivial b = classify (if b then SOME "trivial" else NONE)
+
+   fun collect t v p =
+       G.Monad.map (fn (r, ts, msg) => (r, pretty NONE (layout t v)::ts, msg)) p
+end

Added: mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,17 @@
+(* 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.
+ *)
+
+group is
+   ../../../../../extended-basis/unstable/basis.cm
+   ../../../../../generic/unstable/lib.cm
+   ../../../../../prettier/unstable/lib.cm
+   ../../../../../random/unstable/lib.cm
+   ../../../public/mk-unit-test-fun.sig
+   ../../../public/unit-test.sig
+   ../../fru.sml
+   ../../maybe.sml
+   ../../mk-unit-test.fun
+   ../../sorted-list.sml

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/detail/sorted-list.sml (from rev 5723, mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list.sml	2007-07-04 09:22:44 UTC (rev 5723)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/sorted-list.sml	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,147 @@
+(* 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.
+ *)
+
+(*
+ * Operations on sorted (or ordered) lists.  The provided signature is not
+ * type safe meaning that it is possible to apply these operations to
+ * unsorted lists as well as lists sorted with a different compare
+ * function.
+ *)
+
+structure SortedList :> sig
+   type 'a policy
+   type 'a card = {1 : 'a policy, n : 'a policy} -> 'a policy
+   (**
+    * Cardinality policy is specified as either {#1} or {#n}.  {#1}
+    * means that a sorted list has at most 1 element of any value,
+    * while {#n} means that a list may have any number of equal values.
+    *)
+
+   val insert : 'a card -> 'a Cmp.t -> 'a -> 'a List.t UnOp.t
+   (** {insert #? cmp x xs = merge #? cmp ([x], xs)} *)
+
+   val isSorted : 'a card -> 'a Cmp.t -> 'a List.t UnPr.t
+   (**
+    * Returns true iff the list is sorted to the specified cardinality and
+    * ordering.
+    *)
+
+   val merge : 'a card -> 'a Cmp.t -> 'a List.t BinOp.t
+   (**
+    * Merges two lists sorted to the specified cardinality and ordering.
+    *
+    * It is guaranteed that in {merge #n cmp (l, r)} elements from the
+    * list {l} appear before equal elements from the list {r}.
+    *)
+
+   val remove : 'a card -> 'a Cmp.t -> 'a -> 'a List.t UnOp.t
+   (**
+    * Removes the specified cardinality of elements that compare equal to
+    * the specified element from the sorted list.
+    *)
+
+   val stableSort : 'a card -> 'a Cmp.t -> 'a List.t UnOp.t
+   (**
+    * Sorts the given list to the specified cardinality and ordering.
+    *
+    * It is guaranteed that the relative ordering of equal elements is
+    * retained.
+    *)
+end = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   infix <\ >|
+   (* SML/NJ workaround --> *)
+
+   type 'a policy = {cond : Order.t UnPr.t,
+                     cont : 'a List.t Sq.t UnOp.t UnOp.t,
+                     dups : 'a * 'a List.t -> 'a List.t}
+   type 'a card = {1 : 'a policy, n : 'a policy} -> 'a policy
+
+   fun P m (c : 'a card) =
+       {1 = {cond = LESS <\ op =,
+             cont = const id,
+             dups = Pair.snd},
+        n = {cond = GREATER <\ op <>,
+             cont = id,
+             dups = op ::}} >| c >| m
+
+   fun isSorted card compare = let
+      fun lp [] = true
+        | lp [_] = true
+        | lp (x1::(xs as x2::_)) =
+          P #cond card (compare (x1, x2))
+          andalso lp xs
+   in
+      lp
+   end
+
+   fun revMerge' #? compare (xs, ys) = let
+      fun lp ([], ys, zs) = (ys, zs)
+        | lp (xs, [], zs) = (xs, zs)
+        | lp (x::xs, y::ys, zs) =
+          case compare (x, y) of
+             LESS => lp (xs, y::ys, x::zs)
+           | EQUAL => lp (xs, P #dups #? (y, ys), x::zs)
+           | GREATER => lp (x::xs, ys, y::zs)
+   in
+      lp (xs, ys, [])
+   end
+
+   fun merge #? ? = List.revAppend o Pair.swap o revMerge' #? ?
+
+   fun insert #? compare x xs = merge #? compare ([x], xs)
+
+   fun remove #? compare x ys = let
+      fun lp (zs, []) = (zs, [])
+        | lp (zs, y::ys) =
+          case compare (x, y) of
+             LESS => (zs, y::ys)
+           | EQUAL => P #cont #? lp (zs, ys)
+           | GREATER => lp (y::zs, ys)
+   in
+      List.revAppend (lp ([], ys))
+   end
+
+   (*
+    * This is an optimized implementation of merge sort that tries to
+    * avoid unnecessary list reversals.  This is done by performing
+    * reverse merges and flipping the compare direction as appropriate.
+    *)
+   fun stableSort #? compare = let
+      fun revOdd (w, l) = if Word.isEven w then l else rev l
+      fun merge r =
+          List.revAppend o (if Word.isOdd r then revMerge' #? compare
+                            else revMerge' #? (compare o Pair.swap) o Pair.swap)
+      val finish =
+          fn [] => []
+           | e::es =>
+             revOdd
+                (foldl
+                    (fn ((r1, l1), (r0, l0)) =>
+                        (r1+0w1, merge (r1+0w1) (revOdd (r1-r0, l0), l1)))
+                    e es)
+      fun build (stack as ((r0, l0)::(r1, l1)::rest)) =
+          if r0 <> r1 then push stack
+          else build ((r1+0w1, merge (r1+0w1) (l0, l1))::rest)
+        | build stack = push stack
+      and push stack =
+          fn [] => finish stack
+           | x::xs => let
+             fun lp y ys =
+                 fn [] => finish ((0w1, y::ys)::stack)
+                  | x::xs =>
+                    case compare (x, y) of
+                       LESS => build ((0w1, y::ys)::stack) (x::xs)
+                     | EQUAL => lp x (P #dups #? (y, ys)) xs
+                     | GREATER => lp x (y::ys) xs
+          in
+             lp x [] xs
+          end
+   in
+      push []
+   end
+end

Added: mltonlib/trunk/com/ssh/unit-test/unstable/lib.cm
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib.cm	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib.cm	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,11 @@
+(* 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.
+ *)
+
+library
+   source(-)
+is
+   detail/ml/smlnj/unsealed.cm
+   public/export.sml

Added: mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,39 @@
+(* 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.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+   $(MLTON_LIB)/com/ssh/prettier/unstable/lib.mlb
+   $(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
+in
+   ann
+      "forceUsed"
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      local
+         public/unit-test.sig
+
+         public/mk-unit-test-fun.sig
+         local
+            ann
+               "forceUsed"
+               "sequenceNonUnit warn"
+               "warnUnused true"
+            in
+               detail/fru.sml
+               detail/maybe.sml
+               detail/sorted-list.sml
+            end
+         in
+            detail/mk-unit-test.fun
+         end
+      in
+         public/export.sml
+      end
+   end
+end


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/com/ssh/unit-test/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/export.sml	2007-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/export.sml	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,21 @@
+(* 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.
+ *)
+
+(** == Exported Signatures == *)
+
+signature UNIT_TEST = UNIT_TEST
+
+(** == Exported Functors == *)
+
+functor MkUnitTest (Arg : MK_UNIT_TEST_DOM) :
+   UNIT_TEST
+      where type ('a,     'x) Rep.t = ('a,     'x) Arg.Open.Rep.t
+      where type ('a,     'x) Rep.s = ('a,     'x) Arg.Open.Rep.s
+      where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Open.Rep.p =
+   MkUnitTest (Arg)
+(**
+ * Creates a unit test module.
+ *)


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Added: 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-07-04 09:56:15 UTC (rev 5725)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,15 @@
+(* 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 the domain of the {MkUnitTest} functor.
+ *)
+signature MK_UNIT_TEST_DOM = sig
+   include GENERIC
+   include ARBITRARY sharing Open.Rep = Arbitrary
+   include EQ        sharing Open.Rep = Eq
+   include PRETTY    sharing Open.Rep = Pretty
+end


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
___________________________________________________________________
Name: svn:eol-style
   + native

Copied: mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig (from rev 5602, mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml	2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig	2007-07-04 10:19:14 UTC (rev 5726)
@@ -0,0 +1,165 @@
+(* 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 simple unit testing framework.
+ *)
+signature UNIT_TEST = sig
+   structure Rep : OPEN_GENERIC_REP
+   (** Substructure specifying the representation of generics. *)
+
+   type t
+   (** Type of unit test fold state. *)
+
+   type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+   (** Type of a unit test fold step. *)
+
+   (** == TEST SPECIFICATION INTERFACE == *)
+
+   val unitTests : (t, t, Unit.t, 'a) Fold.f
+   (** Begins test specification. *)
+
+   val title : String.t -> 'a s
+   (** {title string} specifies the title for subsequent tests. *)
+
+   (** === TEST REGISTRATION INTERFACE === *)
+
+   val test : Unit.t Effect.t -> 'a s
+   (**
+    * Registers an ad hoc test.  An ad hoc test 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
+   (** 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 {Type.regExn}.
+    *)
+
+   (** == RANDOM TESTING INTERFACE == *)
+
+   val sizeFn : Int.t UnOp.t -> 'a s
+   (**
+    * 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,
+    *
+    *> all int (fn x => that (x = x))
+    *
+    * specifies that all integers must be equal to themselves.
+    *)
+
+   val that : Bool.t -> law
+   (**
+    * Specifies a primitive boolean law.  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)
+    *
+    * specifies that if {x <= y} then {Int.max (x, y) = y}.
+    *)
+
+   val classify : String.t Option.t -> law UnOp.t
+   (**
+    * Classifies cases of a law.  The distribution of classified cases
+    * will be logged.
+    *)
+
+   val trivial : Bool.t -> law UnOp.t
+   (** Convenience function to classify cases of a law as "trivial". *)
+
+   val collect : ('a, 'x) Rep.t -> 'a -> law UnOp.t
+   (**
+    * Classifies test cases by value of type {'a}.  The distribution as
+    * well as the (pretty printed) values will be logged.
+    *)
+
+   (** == 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
+   (** Verifies that the given value is {true}. *)
+
+   val verifyFalse : Bool.t Effect.t
+   (** Verifies that the given value is {false}. *)
+
+   val verifyFailsWith : 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
+   (** 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