[MLton-commit] r6039

[Matthew Fluet]

More improvements to pretty-printing of CoreML IL
----------------------------------------------------------------------

U   mlton/trunk/mlton/elaborate/elaborate-env.fun
U   mlton/trunk/mlton/elaborate/type-env.fun
U   mlton/trunk/mlton/elaborate/type-env.sig
U   mlton/trunk/mlton/main/compile.fun

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

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-09-19 22:16:16 UTC (rev 6039)
@@ -48,7 +48,6 @@
    structure Tycon = Tycon
    structure Tyvar = Tyvar
    structure Var = Var
-   structure Var = Var
 end
 
 local
@@ -852,7 +851,8 @@
                   layoutTypeSpec' (Ast.Tycon.layout n, s, {isWhere = false})
                and layoutTypeSpec' (name: Layout.t, s, {isWhere: bool}) =
                   let
-                     val {destroy, lay} = Type.makeLayoutPretty {localTyvarNames = true}
+                     val {destroy, lay} = 
+                        Type.makeLayoutPretty {expandOpaque = false, localTyvarNames = true}
                      val lay = #1 o lay
                      val tyvars =
                         case TypeStr.kind s of
@@ -2903,9 +2903,9 @@
                                          Scheme.layoutPretty sigScheme]])
 
                                end
-                         fun addDec (n: Exp.node): Vid.t =
+                         fun addDec (name: string, n: Exp.node): Vid.t =
                             let
-                               val x = Var.newNoname ()
+                               val x = Var.newString name
                                val e = Exp.make (n, strType)
                                val _ =
                                   List.push
@@ -2924,7 +2924,7 @@
                                Vid.Var x
                             end
                          fun con (c: Con.t): Vid.t =
-                            addDec (Exp.Con (c, strArgs ()))
+                            addDec (Con.originalName c, Exp.Con (c, strArgs ()))
                          val vid =
                             case (vid, status) of
                                (Vid.Con c, Status.Var) => con c
@@ -2932,7 +2932,7 @@
                              | (Vid.Var x, Status.Var) =>
                                   if 0 < Vector.length sigArgs
                                      orelse 0 < Vector.length (strArgs ())
-                                     then addDec (Exp.Var (fn () => x, strArgs))
+                                     then addDec (Var.originalName x, Exp.Var (fn () => x, strArgs))
                                   else vid
                              | (Vid.Con _, Status.Con) => vid
                              | (Vid.Exn _, Status.Exn) => vid

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2007-09-19 22:16:16 UTC (rev 6039)
@@ -597,7 +597,7 @@
             Exn.finally (fn () => hom ty, destroy)
          end
 
-      fun makeLayoutPretty {localTyvarNames} : 
+      fun makeLayoutPretty {expandOpaque, localTyvarNames} : 
          {destroy: unit -> unit,
           lay: t -> Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)} =
          let
@@ -663,7 +663,7 @@
             fun var (_, a) = prettyTyvar a
             fun lay t =
                hom (t, {con = con,
-                        expandOpaque = false,
+                        expandOpaque = expandOpaque,
                         flexRecord = flexRecord,
                         genFlexRecord = genFlexRecord,
                         overload = overload,
@@ -676,15 +676,19 @@
              lay = lay}
          end
 
-      fun layoutPrettyAux (t, {localTyvarNames}) =
+      fun layoutPrettyAux (t, {expandOpaque, localTyvarNames}) =
          let
-            val {destroy, lay} = makeLayoutPretty {localTyvarNames = localTyvarNames}
+            val {destroy, lay} = 
+               makeLayoutPretty {expandOpaque = expandOpaque,
+                                 localTyvarNames = localTyvarNames}
             val res = #1 (lay t)
             val _ = destroy ()
          in
             res
          end
-      fun layoutPretty t = layoutPrettyAux (t, {localTyvarNames = true})
+      fun layoutPretty t = 
+         layoutPrettyAux (t, {expandOpaque = false,
+                              localTyvarNames = true})
 
       fun deConOpt t =
          case toType t of
@@ -928,7 +932,8 @@
 
       fun unify (t, t', {preError: unit -> unit}): UnifyResult.t =
          let
-            val {destroy, lay = layoutPretty} = makeLayoutPretty {localTyvarNames = true}
+            val {destroy, lay = layoutPretty} = 
+               makeLayoutPretty {expandOpaque = false, localTyvarNames = true}
             val dontCare' = fn _ => dontCare
             val layoutRecord = fn z => layoutRecord (z, true)
             fun unify arg =

Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig	2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/type-env.sig	2007-09-19 22:16:16 UTC (rev 6039)
@@ -44,14 +44,15 @@
             val isInt: t -> bool
             val isUnit: t -> bool
             val layout: t -> Layout.t
-            val layoutPrettyAux: t * {localTyvarNames: bool} -> Layout.t
+            val layoutPrettyAux: t * {expandOpaque: bool, localTyvarNames: bool} -> Layout.t
             val layoutPretty: t -> Layout.t
             val makeHom: {con: Tycon.t * 'a vector -> 'a,
                           expandOpaque: bool,
                           var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
                                                   hom: t -> 'a}
             val makeLayoutPretty:
-               {localTyvarNames: bool} -> {destroy: unit -> unit,
+               {expandOpaque:bool,
+                localTyvarNames: bool} -> {destroy: unit -> unit,
                                            lay: t -> Layout.t * ({isChar: bool}
                                                                  * Tycon.BindingStrength.t)}
             (* minTime (t, time) makes every component of t occur no later than

Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun	2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/main/compile.fun	2007-09-19 22:16:16 UTC (rev 6039)
@@ -64,7 +64,8 @@
 
                                  fun layout t = 
                                     layoutPrettyAux 
-                                    (t, {localTyvarNames = false})
+                                    (t, {expandOpaque = true,
+                                         localTyvarNames = false})
                               end)
 structure Xml = Xml (open Atoms)
 structure Sxml = Sxml (open Xml)