[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