[MLton-commit] r5965

[Vesa Karvonen]

Changed to use an environment to avoid looping with cyclic data
structures.  Existing tests do not use cyclic data structures, though.

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

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml	2007-08-26 21:02:43 UTC (rev 5964)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml	2007-08-27 00:00:44 UTC (rev 5965)
@@ -7,68 +7,108 @@
 functor WithTransform (Arg : OPEN_CASES) : TRANSFORM_CASES = struct
    (* <-- SML/NJ workaround *)
    open TopLevel
+   infix 4 <\
    (* SML/NJ workaround --> *)
 
+   type e = Univ.t List.t
+   type 'a t = ('a * e) UnOp.t
+
+   fun lift f = Pair.map (f, id)
+
+   val default = id
+
+   fun cyclic t = let
+      val (to, from) = Univ.Emb.new ()
+   in
+      fn (x, e) => if List.exists (SOME x <\ op = o from) e
+                   then (x, e)
+                   else t (x, to x::e)
+   end
+
    structure Transform = LayerRep
      (structure Outer = Arg.Rep
-      structure Closed = MkClosedRep (UnOp))
+      structure Closed = MkClosedRep (type 'a t = 'a t))
 
    fun makeTransform a2a tA tA2tB = let
-      val tA = Transform.This.mapT (const a2a) tA
+      val tA = Transform.This.mapT (const (lift a2a)) tA
       val tB = tA2tB tA
    in
-      Transform.This.getT tB
+      Pair.fst o Transform.This.getT tB o (fn b => (b, []))
    end
 
    structure Layered = LayerCases
      (structure Outer = Arg and Result = Transform and Rep = Transform.Closed
 
-      fun iso rB aIb = Fn.map aIb rB
+      fun iso bT (a2b, b2a) = lift b2a o bT o lift a2b
       val isoProduct = iso
       val isoSum     = iso
 
-      val op *` = Product.map
+      fun op *` (aT, bT) (a & b, e) = let
+         val (a, e) = aT (a, e)
+         val (b, e) = bT (b, e)
+      in
+         (a & b, e)
+      end
       val T      = id
       fun R _    = id
       val tuple  = id
       val record = id
 
-      val op +` = Sum.map
-      val unit  = id
+      fun op +` (aT, bT) (s, e) =
+          case s
+           of INL a => lift INL (aT (a, e))
+            | INR b => lift INR (bT (b, e))
+      val unit  = default
       fun C0 _  = unit
       fun C1 _  = id
       val data  = id
 
       val Y = Tie.function
 
-      fun op --> _ = failing "Transform.--> not yet implemented"
+      fun op --> _ = failing "Transform.--> has no default"
 
-      fun exn _ = fail "Transform.exn not yet implemented"
+      val exn = default
       fun regExn0 _ _ = ()
       fun regExn1 _ _ _ = ()
 
-      val list   =   List.map
-      val vector = Vector.map
+      fun list xT = Pair.map (id, Pair.snd) o
+                    List.unfoldr'
+                       (fn ([],    _) => NONE
+                         | (x::xs, e) =>
+                           case xT (x, e) of (y, e) => SOME (y, (xs, e)))
 
-      fun array tA x = (Array.modify tA x ; x)
-      fun refc  tA x =   (Ref.modify tA x ; x)
+      fun vector xT (v, e) =
+          Vector.unfoldi (xT o lift (v <\ Vector.sub)) (Vector.length v, e)
 
-      val fixedInt = id
-      val largeInt = id
+      fun array aT = cyclic (fn (aA, e) => let
+                                   fun lp (i, e) =
+                                       if i = Array.length aA then e else
+                                       case aT (Array.sub (aA, i), e)
+                                        of (a, e) => (Array.update (aA, i, a)
+                                                    ; lp (i+1, e))
+                                in
+                                   (aA, lp (0, e))
+                                end)
 
-      val largeReal = id
-      val largeWord = id
+      fun refc aT =
+          cyclic (fn (r, e) => case aT (!r, e) of (a, e) => (r := a ; (r, e)))
 
-      val bool   = id
-      val char   = id
-      val int    = id
-      val real   = id
-      val string = id
-      val word   = id
+      val fixedInt = default
+      val largeInt = default
 
-      val word8  = id
-      val word32 = id
-      val word64 = id)
+      val largeReal = default
+      val largeWord = default
 
+      val bool   = default
+      val char   = default
+      val int    = default
+      val real   = default
+      val string = default
+      val word   = default
+
+      val word8  = default
+      val word32 = default
+      val word64 = default)
+
    open Layered
 end