[MLton-commit] r6028

[Vesa Karvonen]

Free variables analysis as a test (or example) of Reduce.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
U   mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml	2007-09-16 12:11:06 UTC (rev 6027)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml	2007-09-17 14:46:58 UTC (rev 6028)
@@ -24,6 +24,32 @@
    in
       testEq toT (fn () => {expect = expect, actual = reduce value})
    end
+
+   structure Lambda =
+      MkLambda (structure Id = struct
+                   type t = String.t
+                   val t = string
+                end
+                open Generic)
+
+   structure Set = struct
+      val empty = []
+      fun singleton x = [x]
+      fun union (xs, ys) = List.nubByEq op = (xs @ ys)
+      fun difference (xs, ys) = List.filter (not o List.contains ys) xs
+   end
+
+   local
+      open Set Lambda
+      val refs = fn REF id => singleton id | _ => empty
+      val decs = fn FUN (id, _) => singleton id | _ => empty
+   in
+      fun free term =
+          difference
+             (union (refs (out term),
+                     makeReduce empty union free t t' term),
+              decs (out term))
+   end
 in
    val () =
        unitTests
@@ -40,5 +66,19 @@
                         [0, 1, 2, 3]
           end
 
+          (testEq (list string)
+                  (fn () => let
+                         open Lambda
+                         fun ` f = IN o f
+                      in
+                         {actual = free (`APP (`FUN ("x",
+                                                     `APP (`REF "y", `REF "x")),
+                                               `FUN ("z",
+                                                     `APP (`REF "x",
+                                                           `APP (`REF "y",
+                                                                 `REF "x"))))),
+                          expect = ["y", "x"]}
+                      end))
+
           $
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml	2007-09-16 12:11:06 UTC (rev 6027)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml	2007-09-17 14:46:58 UTC (rev 6028)
@@ -98,3 +98,57 @@
                       fn INL () => LF | INR ? => BR ?))
    end
 end
+
+functor MkLambda (include GENERIC_EXTRA
+                  structure Id : sig
+                     type t
+                     val t : t Rep.t
+                  end) :> sig
+   structure Id : sig
+      type t = Id.t
+      val t : t Rep.t
+   end
+
+   datatype 't f =
+      FUN of Id.t * 't
+    | APP of 't Sq.t
+    | REF of Id.t
+
+   datatype t = IN of t f
+   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
+   structure Id = Id
+
+   datatype 't f =
+      FUN of Id.t * 't
+    | APP of 't Sq.t
+    | REF of Id.t
+
+   datatype t = IN of t f
+   fun out (IN ?) = ?
+
+   local
+      val cFUN = C "FUN"
+      val cAPP = C "APP"
+      val cREF = C "REF"
+   in
+      fun f t =
+          iso (data (C1 cFUN (tuple2 (Id.t, t))
+                  +` C1 cAPP (sq t)
+                  +` C1 cREF Id.t))
+              (fn FUN ? => INL (INL ?) | APP ? => INL (INR ?) | REF ? => INR ?,
+               fn INL (INL ?) => FUN ? | INL (INR ?) => APP ? | INR ? => REF ?)
+   end
+
+   local
+      val cIN = C "IN"
+   in
+      fun t' t = iso (data (C1 cIN (f t))) (out, IN)
+   end
+
+   val t = Tie.fix Y t'
+end