[MLton-commit] r6461
Vesa Karvonen
vesak at mlton.org
Wed Mar 5 19:19:56 PST 2008
Some basic tests for Uniplate.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/uniplate.sml
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
U mltonlib/trunk/com/ssh/generic/unstable/test.use
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2008-03-06 03:17:56 UTC (rev 6460)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2008-03-06 03:19:55 UTC (rev 6461)
@@ -15,7 +15,6 @@
structure Generic = RootGeneric
-
signature Generic = sig
include Generic TYPE_INFO
end
@@ -30,7 +29,6 @@
MkGeneric (structure Open = WithTypeInfo (Generic)
open Generic Open)
-
signature Generic = sig
include Generic TYPE_HASH
end
@@ -45,7 +43,6 @@
MkGeneric (structure Open = WithTypeHash (Generic)
open Generic Open)
-
signature Generic = sig
include Generic HASH
end
@@ -60,7 +57,20 @@
MkGeneric (structure Open = WithHash (Generic)
open Generic Open)
+signature Generic = sig
+ include Generic UNIPLATE
+end
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure UniplateRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithUniplate (Generic)
+ open Generic Open)
+
signature Generic = sig
include Generic PRETTY
end
@@ -75,7 +85,6 @@
MkGeneric (structure Open = WithPretty (Generic)
open Generic Open)
-
signature Generic = sig
include Generic EQ
end
@@ -90,7 +99,6 @@
MkGeneric (structure Open = WithEq (Generic)
open Generic Open)
-
signature Generic = sig
include Generic SOME
end
@@ -105,7 +113,6 @@
MkGeneric (structure Open = WithSome (Generic)
open Generic Open)
-
signature Generic = sig
include Generic PICKLE
end
@@ -120,7 +127,6 @@
MkGeneric (structure Open = WithPickle (Generic)
open Generic Open)
-
signature Generic = sig
include Generic SEQ
end
@@ -150,7 +156,6 @@
MkGeneric (structure Open = WithRead (Generic)
open Generic Open)
-
signature Generic = sig
include Generic REDUCE
end
@@ -165,7 +170,6 @@
MkGeneric (structure Open = WithReduce (Generic)
open Generic Open)
-
signature Generic = sig
include Generic TRANSFORM
end
@@ -180,7 +184,6 @@
MkGeneric (structure Open = WithTransform (Generic)
open Generic Open)
-
signature Generic = sig
include Generic FMAP
end
@@ -211,7 +214,6 @@
structure RandomGen = RanQD1Gen)
open Generic Open)
-
signature Generic = sig
include Generic SIZE
end
@@ -226,7 +228,6 @@
MkGeneric (structure Open = WithSize (Generic)
open Generic Open)
-
signature Generic = sig
include Generic ORD
end
@@ -241,7 +242,6 @@
MkGeneric (structure Open = WithOrd (Generic)
open Generic Open)
-
signature Generic = sig
include Generic SHRINK
end
Added: mltonlib/trunk/com/ssh/generic/unstable/test/uniplate.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/uniplate.sml 2008-03-06 03:17:56 UTC (rev 6460)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/uniplate.sml 2008-03-06 03:19:55 UTC (rev 6461)
@@ -0,0 +1,83 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ open Generic UnitTest
+
+ structure BinTree = MkBinTree (Generic)
+
+ fun testUniplate t =
+ testAll t (fn x =>
+ case uniplate t x
+ of (c, c2x) =>
+ (thatEq t {expect = x, actual = c2x c}
+ ; thatEq (list t) {expect = c, actual = children t x}))
+
+ fun testFoldU t =
+ testAll t (fn x =>
+ thatEq (list t)
+ {expect = universe t x,
+ actual = rev (foldU t op :: [] x)})
+
+ fun testRewrite t f =
+ testAll t (fn x =>
+ app (fn x =>
+ thatEq (option t)
+ {expect = NONE,
+ actual = f x})
+ (universe t (rewrite t f x)))
+
+ fun testHolesU t =
+ testAll t (fn x =>
+ (thatEq (list t)
+ {expect = universe t x,
+ actual = map #1 (holesU t x)}
+ ; app (fn (y, y2x) =>
+ thatEq t {expect = x,
+ actual = y2x y})
+ (holesU t x)))
+in
+ val () =
+ unitTests
+ (title "Generic.Uniplate")
+
+ (testUniplate (BinTree.t int))
+ (testUniplate (list int))
+
+ (title "Generic.Uniplate.foldU")
+
+ (testFoldU (BinTree.t int))
+ (testFoldU (list int))
+
+ (title "Generic.Uniplate.rewrite")
+
+ let
+ open BinTree
+ val tryL =
+ fn BR (BR (a, x, b), y, r) =>
+ if y < x then SOME (BR (BR (a, y, b), x, r)) else NONE
+ | _ => NONE
+ val tryR =
+ fn BR (l, y, BR (c, z, d)) =>
+ if z < y then SOME (BR (l, z, BR (c, y, d))) else NONE
+ | _ => NONE
+ in
+ testRewrite
+ (t int)
+ (fn x => case tryL x of NONE => tryR x | some => some)
+ end
+
+ (testRewrite (list int)
+ (fn x::y::r => if y < x then SOME (y::x::r) else NONE
+ | _ => NONE))
+
+ (title "Generic.Uniplate.holesU")
+
+ (testHolesU (BinTree.t int))
+ (testHolesU (list int))
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/uniplate.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2008-03-06 03:17:56 UTC (rev 6460)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2008-03-06 03:19:55 UTC (rev 6461)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 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.
@@ -20,6 +20,7 @@
with/type-info.sml
with/type-hash.sml
with/hash.sml
+ with/uniplate.sml
with/pretty.sml
with/eq.sml
with/some.sml
@@ -47,5 +48,6 @@
test/reduce.sml
test/some.sml
test/transform.sml
+ test/uniplate.sml
end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.use 2008-03-06 03:17:56 UTC (rev 6460)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.use 2008-03-06 03:19:55 UTC (rev 6461)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 Vesa Karvonen
+(* Copyright (C) 2007-2008 Vesa Karvonen
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
@@ -13,6 +13,7 @@
"with/type-info.sml",
"with/type-hash.sml",
"with/hash.sml",
+ "with/uniplate.sml",
"with/pretty.sml",
"with/eq.sml",
"with/some.sml",
@@ -36,4 +37,5 @@
"test/read.sml",
"test/reduce.sml",
"test/some.sml",
- "test/transform.sml"] ;
+ "test/transform.sml",
+ "test/uniplate.sml"] ;
More information about the MLton-commit
mailing list