[MLton-commit] r6385
Vesa Karvonen
vesak at mlton.org
Tue Feb 5 02:34:58 PST 2008
Changed the order of arguments to makeReduce and makeTransform putting the
type representation constructor first. This seems be the more commonly
desired partial application: defining reduce and transform operations for
a particular type constructor.
Also simplified the MkLambda functor and the reduce test.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/example/canonize.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2008-02-05 10:34:57 UTC (rev 6385)
@@ -32,7 +32,7 @@
open ReduceRep.This
- fun makeReduce z p a2r aT aT2bT = let
+ fun makeReduce aT2bT aT z p a2r = let
val (to, from) = Univ.Iso.new ()
val z = to z
val p = BinOp.map (from, to) p
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2008-02-05 10:34:57 UTC (rev 6385)
@@ -41,7 +41,7 @@
open TransformRep.This
- fun makeTransform a2a t t2u =
+ fun makeTransform t2u t a2a =
case getT (t2u (mapT (const (IN (CUSTOM, lift a2a))) t))
of IN (_, f) =>
fn x => f (x, HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash})
Modified: mltonlib/trunk/com/ssh/generic/unstable/example/canonize.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/example/canonize.sml 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/example/canonize.sml 2008-02-05 10:34:57 UTC (rev 6385)
@@ -74,8 +74,8 @@
open Lambda
(* Shorthands for reducing and transforming terms: *)
-fun reduce z p l = makeReduce z p l t f
-fun transform g = makeTransform g t f
+fun reduce ? = makeReduce f t ?
+fun transform ? = makeTransform f t ?
(* The {Set} structure implements a naive set for our example: *)
structure Set = struct
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2008-02-05 10:34:57 UTC (rev 6385)
@@ -9,17 +9,17 @@
*
* Examples:
*
- *> - val sum = makeReduce 0 op + id int list ;
+ *> - val sum = makeReduce list int 0 op + id ;
*> val sum = fn : Int.t List.t -> Int.t
*> - sum [1, 2, 3] ;
*> val it = 6 : Int.t
*
- *> - val count = makeReduce 0 op + (const 1) real list ;
+ *> - val count = makeReduce list real 0 op + (const 1) ;
*> val count = fn : Real.t List.t -> Int.t
*> - count [1.0, 4.0, 6.0] ;
*> val it = 3 : Int.t
*
- *> - makeReduce 0 op + id int (fn t => tuple (T t *` T int *` T t))
+ *> - makeReduce (fn t => tuple (T t *` T int *` T t)) int 0 op + id
*> = (1 & 3 & 7) ;
*> val it = 8 : Int.t
*
@@ -29,11 +29,11 @@
structure ReduceRep : OPEN_REP
val makeReduce :
- 'r
+ (('a, 'x) ReduceRep.t -> ('b, 'y) ReduceRep.t)
+ -> ('a, 'x) ReduceRep.t
+ -> 'r
-> 'r BinOp.t
-> ('a -> 'r)
- -> ('a, 'x) ReduceRep.t
- -> (('a, 'x) ReduceRep.t -> ('b, 'y) ReduceRep.t)
-> 'b -> 'r
(** Creates a reduce operation. *)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2008-02-05 10:34:57 UTC (rev 6385)
@@ -12,10 +12,10 @@
*
* Examples:
*
- *> - makeTransform (fn x => x + 1) int list [1, 2, 3] ;
+ *> - makeTransform list int (fn x => x + 1) [1, 2, 3] ;
*> val it = [2, 3, 4] : Int.t List.t
*
- *> - makeTransform op ~ int (fn t => tuple (T int *` T t)) (1 & 3) ;
+ *> - makeTransform (fn t => tuple (T int *` T t)) int op ~ (1 & 3) ;
*> val it = (1 & ~3) : (Int.t, Int.t) Product.t
*
* This design is experimental.
@@ -24,9 +24,9 @@
structure TransformRep : OPEN_REP
val makeTransform :
- 'a UnOp.t
+ (('a, 'x) TransformRep.t -> ('b, 'y) TransformRep.t)
-> ('a, 'x) TransformRep.t
- -> (('a, 'x) TransformRep.t -> ('b, 'y) TransformRep.t)
+ -> 'a UnOp.t
-> 'b UnOp.t
(** Creates a transform operation. *)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml 2008-02-05 10:34:57 UTC (rev 6385)
@@ -9,8 +9,8 @@
structure BinTree = MkBinTree (Generic)
- fun testReduce zero binOp to fromT t2t toT value expect = let
- val reduce = makeReduce zero binOp to fromT t2t
+ fun testReduce t2t fromT toT zero binOp to value expect = let
+ val reduce = makeReduce t2t fromT zero binOp to
in
testEq toT (fn () => {expect = expect, actual = reduce value})
end
@@ -34,24 +34,24 @@
val refs = fn REF id => singleton id | _ => empty
val decs = fn FUN (id, _) => singleton id | _ => empty
in
- fun free term =
+ fun free (IN term) =
difference
- (union (refs (out term),
- makeReduce empty union free t t' term),
- decs (out term))
+ (union (refs term,
+ makeReduce f t empty union free term),
+ decs term)
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
+ (testReduce list int int 0 op + id [1, 2, 3] 6)
+ (testReduce list real int 0 op + (const 1) [1.0, 4.0, 6.0] 3)
+ (testReduce (fn t => tuple (T t *` T int *` T t)) int int 0 op + id
(1 & 3 & 7) 8)
let open BinTree in
- testReduce [] op @ (fn x => [x]) int t (list int)
+ testReduce t int (list int) [] op @ (fn x => [x])
(BR (BR (LF, 0, LF), 1, BR (LF, 2, BR (LF, 3, LF))))
[0, 1, 2, 3]
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2008-02-05 10:34:57 UTC (rev 6385)
@@ -7,8 +7,8 @@
local
open Generic UnitTest
- fun testTransform unOp t t2t value expect = let
- val transform = makeTransform unOp t t2t
+ fun testTransform t2t t unOp value expect = let
+ val transform = makeTransform t2t t unOp
in
testEq (t2t t) (fn () => {expect = expect, actual = transform value})
end
@@ -20,19 +20,19 @@
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))
+ (testTransform list int (1 <\ op +) [1, 2, 3] [2, 3, 4])
+ (testTransform (fn t => tuple (T int *` T t)) int op ~ (1 & 3) (1 & ~3))
let
datatype t = datatype BinTree.t
in
testTransform
- (1 <\ op +) int BinTree.t
+ BinTree.t int (1 <\ op +)
(BR (BR (LF, 0, LF), 1, BR (LF, 2, BR (LF, 3, LF))))
(BR (BR (LF, 1, LF), 2, BR (LF, 3, BR (LF, 4, LF))))
end
- (testTransform op ~ int Graph.t Graph.intGraph1 Graph.intGraph1)
+ (testTransform Graph.t int op ~ Graph.intGraph1 Graph.intGraph1)
$
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun 2008-02-05 10:06:39 UTC (rev 6384)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun 2008-02-05 10:34:57 UTC (rev 6385)
@@ -100,7 +100,6 @@
val out : t -> t f
val f : 't Rep.t -> 't f Rep.t
- val t' : t Rep.t UnOp.t
val t : t Rep.t
end = struct
(* <--- SML/NJ workaround *)
@@ -134,8 +133,6 @@
local
val cIN = C "IN"
in
- fun t' t = iso (data (C1 cIN (f t))) (out, IN)
+ val t = Tie.fix Y (fn t => iso (data (C1 cIN (f t))) (out, IN))
end
-
- val t = Tie.fix Y t'
end
More information about the MLton-commit
mailing list