[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