[MLton-commit] r5936
Vesa Karvonen
vesak at mlton.org
Fri Aug 24 05:18:04 PDT 2007
Added ad-hoc tests for reduce and transform. Some refactoring.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
D mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-08-23 12:28:48 UTC (rev 5935)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-08-24 12:18:02 UTC (rev 5936)
@@ -4,7 +4,21 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-val () = let
+local
+ structure Generic = struct
+ open Generic
+ local
+ structure Open = WithSeq (Open)
+ structure Extra = CloseWithExtra (Open)
+ in
+ val seq = Open.seq
+ open Extra
+ end
+ end
+
+ structure Graph = MkGraph (Generic)
+ structure ExnArray = MkExnArray (Generic)
+
open Generic UnitTest
fun chkEq t =
@@ -31,25 +45,26 @@
(fn () => unpickle u p)
end)
in
- unitTests
- (title "Generic.Pickle")
+ val () =
+ unitTests
+ (title "Generic.Pickle")
- (chkEq (vector (option (list real))))
- (chkEq (tuple2 (fixedInt, largeInt)))
- (chkEq (largeReal &` largeWord))
- (chkEq (tuple3 (word8, word32, word64)))
- (chkEq (bool &` char &` int &` real &` string &` word))
+ (chkEq (vector (option (list real))))
+ (chkEq (tuple2 (fixedInt, largeInt)))
+ (chkEq (largeReal &` largeWord))
+ (chkEq (tuple3 (word8, word32, word64)))
+ (chkEq (bool &` char &` int &` real &` string &` word))
- (title "Generic.Pickle.Cyclic")
+ (title "Generic.Pickle.Cyclic")
- (testSeq (Graph.t int) Graph.intGraph1)
- (testSeq (array exn) ExnArray.exnArray1)
+ (testSeq (Graph.t int) Graph.intGraph1)
+ (testSeq (array exn) ExnArray.exnArray1)
- (title "Generic.Pickle.TypeMismatch")
+ (title "Generic.Pickle.TypeMismatch")
- (testTypeMismatch int word)
- (testTypeMismatch (list char) (vector char))
- (testTypeMismatch (array real) (option real))
+ (testTypeMismatch int word)
+ (testTypeMismatch (list char) (vector char))
+ (testTypeMismatch (array real) (option real))
- $
+ $
end
Added: mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml 2007-08-23 12:28:48 UTC (rev 5935)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml 2007-08-24 12:18:02 UTC (rev 5936)
@@ -0,0 +1,37 @@
+(* 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
+ structure Generic = struct
+ open Generic
+ local
+ structure Open = WithReduce (Open)
+ structure Extra = CloseWithExtra (Open)
+ in
+ val makeReduce = Open.makeReduce
+ open Extra
+ end
+ end
+
+ open Generic UnitTest
+
+ fun testReduce zero binOp to fromT t2t toT value expect = let
+ val reduce = makeReduce zero binOp to fromT t2t
+ in
+ testEq toT (fn () => {expect = expect, actual = reduce value})
+ end
+in
+ val () =
+ unitTests
+ (title "Generic.Reduce")
+
+ (testReduce 0 op + id int list int [1, 2, 3] 6)
+ (testReduce 0 op + (const 1) real list int [1.0, 4.0, 6.0] 3)
+ (testReduce 0 op + id int (fn t => tuple (T t *` T int *` T t)) int
+ (1 & 3 & 7) 8)
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Deleted: mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml 2007-08-23 12:28:48 UTC (rev 5935)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml 2007-08-24 12:18:02 UTC (rev 5936)
@@ -1,70 +0,0 @@
-(* 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.
- *)
-
-(* Some tests need the structural/sharing equality {Seq}. *)
-structure Generic = struct
- open Generic
- local
- structure Open = WithSeq (Open)
- structure Closed = CloseCases (Open)
- structure Extra = WithExtra (structure Open = Open open Open Closed)
- in
- val seq = Open.seq
- open Extra
- end
-end
-
-(* A simplistic graph for testing with cyclic data. *)
-structure Graph :> sig
- type 'a t
- val t : 'a Generic.Rep.t -> 'a t Generic.Rep.t
- val intGraph1 : Int.t t
-end = struct
- datatype 'a t = VTX of 'a * 'a t List.t Ref.t
-
- local
- open Tie Generic
- val vtx = C "VTX"
- in
- fun t a =
- fix Y (fn aT =>
- iso (data (C1 vtx (tuple2 (a, refc (list aT)))))
- (fn VTX ? => ?, VTX))
- end
-
- fun arcs (VTX (_, r)) = r
-
- val intGraph1 = let
- val a = VTX (1, ref [])
- val b = VTX (2, ref [])
- val c = VTX (3, ref [])
- val d = VTX (4, ref [])
- val e = VTX (5, ref [])
- val f = VTX (6, ref [])
- in
- arcs a := [b, d]
- ; arcs b := [c, e]
- ; arcs c := [a, f]
- ; arcs d := [f]
- ; arcs e := [d]
- ; arcs f := [e]
- ; a
- end
-end
-
-(* A contrived recursive exception constructor for testing with cyclic data. *)
-structure ExnArray :> sig
- exception ExnArray of Exn.t Array.t
- val exnArray1 : Exn.t Array.t
-end = struct
- open Generic
-
- exception ExnArray of Exn.t Array.t
- val () = regExn1' "ExnArray" (array exn) ExnArray (fn ExnArray ? => ?)
-
- val exnArray1 = Array.fromList [Empty]
- val () = Array.update (exnArray1, 0, ExnArray exnArray1)
-end
Added: mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2007-08-23 12:28:48 UTC (rev 5935)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2007-08-24 12:18:02 UTC (rev 5936)
@@ -0,0 +1,35 @@
+(* 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
+ structure Generic = struct
+ open Generic
+ local
+ structure Open = WithTransform (Open)
+ structure Extra = CloseWithExtra (Open)
+ in
+ val makeTransform = Open.makeTransform
+ open Extra
+ end
+ end
+
+ open Generic UnitTest
+
+ fun testTransform unOp t t2t value expect = let
+ val transform = makeTransform unOp t t2t
+ in
+ testEq (t2t t) (fn () => {expect = expect, actual = transform value})
+ end
+in
+ val () =
+ unitTests
+ (title "Generic.Transform")
+
+ (testTransform (1 <\ op +) int list [1, 2, 3] [2, 3, 4])
+ (testTransform op ~ int (fn t => tuple (T int *` T t)) (1 & 3) (1 & ~3))
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Copied: mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml (from rev 5934, mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml 2007-08-23 09:46:45 UTC (rev 5934)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml 2007-08-24 12:18:02 UTC (rev 5936)
@@ -0,0 +1,61 @@
+(* 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.
+ *)
+
+(* Helper for adding a new generic. *)
+functor CloseWithExtra (Open : OPEN_CASES) =
+ WithExtra (structure Open = Open and Closed = CloseCases (Open) open Closed)
+
+(* A simplistic graph for testing with cyclic data. *)
+functor MkGraph (Generic : GENERIC_EXTRA) :> sig
+ type 'a t
+ val t : 'a Generic.Rep.t -> 'a t Generic.Rep.t
+ val intGraph1 : Int.t t
+end = struct
+ datatype 'a t = VTX of 'a * 'a t List.t Ref.t
+
+ local
+ open Tie Generic
+ val vtx = C "VTX"
+ in
+ fun t a =
+ fix Y (fn aT =>
+ iso (data (C1 vtx (tuple2 (a, refc (list aT)))))
+ (fn VTX ? => ?, VTX))
+ end
+
+ fun arcs (VTX (_, r)) = r
+
+ val intGraph1 = let
+ val a = VTX (1, ref [])
+ val b = VTX (2, ref [])
+ val c = VTX (3, ref [])
+ val d = VTX (4, ref [])
+ val e = VTX (5, ref [])
+ val f = VTX (6, ref [])
+ in
+ arcs a := [b, d]
+ ; arcs b := [c, e]
+ ; arcs c := [a, f]
+ ; arcs d := [f]
+ ; arcs e := [d]
+ ; arcs f := [e]
+ ; a
+ end
+end
+
+(* A contrived recursive exception constructor for testing with cyclic data. *)
+functor MkExnArray (Generic : GENERIC_EXTRA) :> sig
+ exception ExnArray of Exn.t Array.t
+ val exnArray1 : Exn.t Array.t
+end = struct
+ open Generic
+
+ exception ExnArray of Exn.t Array.t
+ val () = regExn1' "ExnArray" (array exn) ExnArray (fn ExnArray ? => ?)
+
+ val exnArray1 = Array.fromList [Empty]
+ val () = Array.update (exnArray1, 0, ExnArray exnArray1)
+end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-08-23 12:28:48 UTC (rev 5935)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-08-24 12:18:02 UTC (rev 5936)
@@ -15,11 +15,13 @@
"warnUnused true"
in
local
- test/test-utils.sml
+ test/utils.sml
in
test/pickle.sml
test/pretty.sml
+ test/reduce.sml
test/some.sml
+ test/transform.sml
end
end
in
More information about the MLton-commit
mailing list