[MLton-commit] r6037
Matthew Fluet
fluet at mlton.org
Wed Sep 19 09:50:04 PDT 2007
Improvements to pretty-printing of CoreML IL
----------------------------------------------------------------------
U mlton/trunk/mlton/core-ml/core-ml.fun
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/core-ml/core-ml.fun
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/core-ml/core-ml.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -22,6 +22,16 @@
else x
end
+fun layoutTargs (ts: Type.t vector) =
+ let
+ open Layout
+ in
+ if !Control.showTypes
+ andalso 0 < Vector.length ts
+ then list (Vector.toListMap (ts, Type.layout))
+ else empty
+ end
+
structure Pat =
struct
datatype t = T of {node: node,
@@ -56,9 +66,7 @@
case node p of
Con {arg, con, targs} =>
seq [Con.layout con,
- if !Control.showTypes andalso 0 < Vector.length targs
- then tuple (Vector.toListMap (targs, Type.layout))
- else empty,
+ layoutTargs targs,
case arg of
NONE => empty
| SOME p => seq [str " ", layout p]]
@@ -194,7 +202,7 @@
local
open Layout
in
- fun layoutTyvars ts =
+ fun layoutTyvars (ts: Tyvar.t vector) =
case Vector.length ts of
0 => empty
| 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
@@ -238,7 +246,7 @@
rules = Vector.map (rules, fn {exp, pat, ...} =>
(Pat.layout pat, layoutExp exp)),
test = layoutExp test}
- | Con (c, _) => Con.layout c
+ | Con (c, targs) => seq [Con.layout c, layoutTargs targs]
| Const f => Const.layout (f ())
| EnterLeave (e, si) =>
seq [str "EnterLeave ",
@@ -265,19 +273,32 @@
record = r,
separator = " = "}
| Seq es => Pretty.seq (Vector.map (es, layoutExp))
- | Var (x, _) => Var.layout (x ())
+ | Var (var, targs) =>
+ if !Control.showTypes
+ then let
+ open Layout
+ val targs = targs ()
+ in
+ if Vector.isEmpty targs
+ then Var.layout (var ())
+ else seq [Var.layout (var ()), str " ",
+ Vector.layout Type.layout targs]
+ end
+ else Var.layout (var ())
and layoutFuns (tyvars, decs) =
if 0 = Vector.length decs
then empty
else
align [seq [str "val rec", layoutTyvars (tyvars ())],
indent (align (Vector.toListMap
- (decs, fn {lambda, var} =>
- align [seq [Var.layout var, str " = "],
+ (decs, fn {lambda as Lam {argType, body = Exp {ty = bodyType, ...}, ...}, var} =>
+ align [seq [maybeConstrain (Var.layout var, Type.arrow (argType, bodyType)), str " = "],
indent (layoutLambda lambda, 3)])),
3)]
- and layoutLambda (Lam {arg, body, ...}) =
- paren (align [seq [str "fn ", Var.layout arg, str " =>"],
+ and layoutLambda (Lam {arg, argType, body, ...}) =
+ paren (align [seq [str "fn ",
+ maybeConstrain (Var.layout arg, argType),
+ str " =>"],
layoutExp body])
end
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -852,7 +852,7 @@
layoutTypeSpec' (Ast.Tycon.layout n, s, {isWhere = false})
and layoutTypeSpec' (name: Layout.t, s, {isWhere: bool}) =
let
- val {destroy, lay} = Type.makeLayoutPretty ()
+ val {destroy, lay} = Type.makeLayoutPretty {localTyvarNames = true}
val lay = #1 o lay
val tyvars =
case TypeStr.kind s of
Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -597,10 +597,9 @@
Exn.finally (fn () => hom ty, destroy)
end
- fun makeLayoutPretty (): {destroy: unit -> unit,
- lay: t -> Layout.t
- * ({isChar: bool}
- * Tycon.BindingStrength.t)} =
+ fun makeLayoutPretty {localTyvarNames} :
+ {destroy: unit -> unit,
+ lay: t -> Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)} =
let
val str = Layout.str
fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -632,30 +631,35 @@
| SOME ts => Tycon.layoutApp (Tycon.tuple, ts)
fun recursive _ = simple (str "<recur>")
fun unknown _ = simple (str "???")
- val {destroy, get = prettyTyvar, ...} =
- Property.destGet
- (Tyvar.plist,
- Property.initFun
- (let
- val r = ref (Char.toInt #"a")
- in
- fn _ =>
- let
- val n = !r
- val l =
- simple
- (str (concat
- ["'",
- if n > Char.toInt #"z" then
- concat ["a",
- Int.toString (n - Char.toInt #"z")]
- else
- Char.toString (Char.fromInt n )]))
- val _ = r := 1 + n
- in
- l
- end
- end))
+ val (destroy, prettyTyvar) =
+ if localTyvarNames
+ then let
+ val {destroy, get = prettyTyvar, ...} =
+ Property.destGet
+ (Tyvar.plist,
+ Property.initFun
+ (let
+ val r = ref (Char.toInt #"a")
+ in
+ fn _ =>
+ let
+ val n = !r
+ val l =
+ simple
+ (str (concat
+ ["'",
+ if n > Char.toInt #"z"
+ then concat ["a", Int.toString (n - Char.toInt #"z")]
+ else Char.toString (Char.fromInt n )]))
+ val _ = r := 1 + n
+ in
+ l
+ end
+ end))
+ in
+ (destroy, prettyTyvar)
+ end
+ else (fn () => (), simple o Tyvar.layout)
fun var (_, a) = prettyTyvar a
fun lay t =
hom (t, {con = con,
@@ -672,14 +676,15 @@
lay = lay}
end
- fun layoutPretty t =
+ fun layoutPrettyAux (t, {localTyvarNames}) =
let
- val {destroy, lay} = makeLayoutPretty ()
+ val {destroy, lay} = makeLayoutPretty {localTyvarNames = localTyvarNames}
val res = #1 (lay t)
val _ = destroy ()
in
res
end
+ fun layoutPretty t = layoutPrettyAux (t, {localTyvarNames = true})
fun deConOpt t =
case toType t of
@@ -923,7 +928,7 @@
fun unify (t, t', {preError: unit -> unit}): UnifyResult.t =
let
- val {destroy, lay = layoutPretty} = makeLayoutPretty ()
+ val {destroy, lay = layoutPretty} = makeLayoutPretty {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 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/type-env.sig 2007-09-19 16:50:01 UTC (rev 6037)
@@ -44,15 +44,16 @@
val isInt: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t
+ val layoutPrettyAux: t * {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:
- unit -> {destroy: unit -> unit,
- lay: t -> Layout.t * ({isChar: bool}
- * Tycon.BindingStrength.t)}
+ {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
* time. This will display a type error message if time is before
* the definition time of some component of t.
Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/main/compile.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -62,7 +62,9 @@
expandOpaque = true,
var = var}
- val layout = layoutPretty
+ fun layout t =
+ layoutPrettyAux
+ (t, {localTyvarNames = false})
end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
More information about the MLton-commit
mailing list