Menu
▾
▴
[MLton-commit] r5014
|
From: Vesa K. <ve...@ml...> - 2007-01-07 08:34:22
|
Implemented a more precise algorithm to eliminate redundant parentheses
from the show-basis output.
----------------------------------------------------------------------
U mlton/trunk/mlton/ast/prim-tycons.fun
U mlton/trunk/mlton/ast/prim-tycons.sig
U mlton/trunk/mlton/ast/sources.cm
U mlton/trunk/mlton/ast/sources.mlb
U mlton/trunk/mlton/atoms/hash-type.fun
U mlton/trunk/mlton/elaborate/elaborate-env.fun
U mlton/trunk/mlton/elaborate/interface.fun
U mlton/trunk/mlton/elaborate/interface.sig
U mlton/trunk/mlton/elaborate/type-env.fun
U mlton/trunk/mlton/elaborate/type-env.sig
U mlton/trunk/mlton/ssa/ssa-tree2.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ast/prim-tycons.fun
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/prim-tycons.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -11,6 +11,18 @@
open S
+structure BindingStrength =
+ struct
+ datatype t =
+ Arrow
+ | Tuple
+ | Unit
+
+ val arrow = Arrow
+ val tuple = Tuple
+ val unit = Unit
+ end
+
datatype z = datatype RealSize.t
type tycon = t
@@ -165,7 +177,8 @@
val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
fun layoutApp (c: t,
- args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
+ args: (Layout.t * ({isChar: bool}
+ * BindingStrength.t)) vector) =
let
local
open Layout
@@ -174,37 +187,52 @@
val seq = seq
val str = str
end
- fun maybe (l, {isChar = _, needsParen}) =
- if needsParen
- then Layout.paren l
- else l
+ datatype z = datatype BindingStrength.t
+ datatype binding_context =
+ ArrowLhs
+ | ArrowRhs
+ | TupleElem
+ | Tyseq1
+ | TyseqN
+ fun maybe bindingContext (l, ({isChar = _}, bindingStrength)) =
+ case (bindingStrength, bindingContext) of
+ (Unit, _) => l
+ | (Tuple, ArrowLhs) => l
+ | (Tuple, ArrowRhs) => l
+ | (Tuple, TyseqN) => l
+ | (Arrow, ArrowRhs) => l
+ | (Arrow, TyseqN) => l
+ | _ => Layout.paren l
fun normal () =
let
val ({isChar}, lay) =
case Vector.length args of
0 => ({isChar = equals (c, defaultChar ())}, layout c)
| 1 => ({isChar = false},
- seq [maybe (Vector.sub (args, 0)), str " ", layout c])
+ seq [maybe Tyseq1 (Vector.sub (args, 0)),
+ str " ", layout c])
| _ => ({isChar = false},
- seq [Layout.tuple (Vector.toListMap (args, maybe)),
+ seq [Layout.tuple
+ (Vector.toListMap (args, maybe TyseqN)),
str " ", layout c])
in
- (lay, {isChar = isChar, needsParen = false})
+ (lay, ({isChar = isChar}, Unit))
end
in
if equals (c, arrow)
- then (mayAlign [maybe (Vector.sub (args, 0)),
- seq [str "-> ", maybe (Vector.sub (args, 1))]],
- {isChar = false, needsParen = true})
+ then (mayAlign [maybe ArrowLhs (Vector.sub (args, 0)),
+ seq [str "-> ",
+ maybe ArrowRhs (Vector.sub (args, 1))]],
+ ({isChar = false}, Arrow))
else if equals (c, tuple)
then if 0 = Vector.length args
- then (str "unit", {isChar = false, needsParen = false})
+ then (str "unit", ({isChar = false}, Unit))
else (mayAlign (Layout.separateLeft
- (Vector.toListMap (args, maybe), "* ")),
- {isChar = false, needsParen = true})
+ (Vector.toListMap (args, maybe TupleElem), "* ")),
+ ({isChar = false}, Tuple))
else if equals (c, vector)
- then if #isChar (#2 (Vector.sub (args, 0)))
- then (str "string", {isChar = false, needsParen = false})
+ then if #isChar (#1 (#2 (Vector.sub (args, 0))))
+ then (str "string", ({isChar = false}, Unit))
else normal ()
else normal ()
end
Modified: mlton/trunk/mlton/ast/prim-tycons.sig
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.sig 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/prim-tycons.sig 2007-01-07 16:33:41 UTC (rev 5014)
@@ -27,10 +27,21 @@
val layout: t -> Layout.t
end
+signature BINDING_STRENGTH =
+ sig
+ type t
+
+ val arrow: t
+ val tuple: t
+ val unit: t
+ end
+
signature PRIM_TYCONS =
sig
include PRIM_TYCONS_SUBSTRUCTS
+ structure BindingStrength: BINDING_STRENGTH
+
type tycon
val array: tycon
@@ -57,8 +68,8 @@
val isRealX: tycon -> bool
val isWordX: tycon -> bool
val layoutApp:
- tycon * (Layout.t * {isChar: bool, needsParen: bool}) vector
- -> Layout.t * {isChar: bool, needsParen: bool}
+ tycon * (Layout.t * ({isChar: bool} * BindingStrength.t)) vector
+ -> Layout.t * ({isChar: bool} * BindingStrength.t)
val list: tycon
val pointer: tycon
val prims: {admitsEquality: AdmitsEquality.t,
Modified: mlton/trunk/mlton/ast/sources.cm
===================================================================
--- mlton/trunk/mlton/ast/sources.cm 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/sources.cm 2007-01-07 16:33:41 UTC (rev 5014)
@@ -10,6 +10,7 @@
signature ADMITS_EQUALITY
signature AST
+signature BINDING_STRENGTH
signature CHAR_SIZE
signature FIELD
signature INT_SIZE
Modified: mlton/trunk/mlton/ast/sources.mlb
===================================================================
--- mlton/trunk/mlton/ast/sources.mlb 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/sources.mlb 2007-01-07 16:33:41 UTC (rev 5014)
@@ -56,6 +56,7 @@
in
signature ADMITS_EQUALITY
signature AST
+ signature BINDING_STRENGTH
signature CHAR_SIZE
signature FIELD
signature INT_SIZE
Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/atoms/hash-type.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,8 +84,9 @@
fun layout (ty: t): Layout.t =
#1 (hom {con = Tycon.layoutApp,
ty = ty,
- var = fn a => (Tyvar.layout a, {isChar = false,
- needsParen = false})})
+ var = fn a => (Tyvar.layout a,
+ ({isChar = false},
+ Tycon.BindingStrength.unit))})
val toString = Layout.toString o layout
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,7 +84,7 @@
fun explainDoesNotAdmitEquality (t: t): Layout.t =
let
open Layout
- val wild = (str "_", {isChar = false, needsParen = false})
+ val wild = (str "_", ({isChar = false}, Tycon.BindingStrength.unit))
fun con (c, ts) =
let
fun keep {showInside: bool} =
@@ -101,7 +101,8 @@
case ! (Tycon.admitsEquality c) of
Always => NONE
| Never => SOME (bracket (#1 (keep {showInside = false})),
- {isChar = false, needsParen = false})
+ ({isChar = false},
+ Tycon.BindingStrength.unit))
| Sometimes =>
if Vector.exists (ts, Option.isSome)
then SOME (keep {showInside = true})
@@ -134,7 +135,7 @@
seq [Field.layout f, str ": ", z] :: ac),
",")),
str ending],
- {isChar = false, needsParen = false})
+ ({isChar = false}, Tycon.BindingStrength.unit))
end
| SOME v =>
Tycon.layoutApp
Modified: mlton/trunk/mlton/elaborate/interface.fun
===================================================================
--- mlton/trunk/mlton/elaborate/interface.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/interface.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -144,7 +144,8 @@
("id", TyconId.layout id)]
end
- fun layoutApp (t, _) = (layout t, {isChar = false, needsParen = false})
+ fun layoutApp (t, _) =
+ (layout t, ({isChar = false}, Etycon.BindingStrength.unit))
val copies: copy list ref = ref []
@@ -247,7 +248,7 @@
local
open Layout
- fun simple l = (l, {isChar = false, needsParen = false})
+ fun simple l = (l, ({isChar = false}, Etycon.BindingStrength.unit))
fun loop t =
case t of
Con (c, ts) => Tycon.layoutApp (c, Vector.map (ts, loop))
Modified: mlton/trunk/mlton/elaborate/interface.sig
===================================================================
--- mlton/trunk/mlton/elaborate/interface.sig 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/interface.sig 2007-01-07 16:33:41 UTC (rev 5014)
@@ -15,6 +15,8 @@
structure Kind: TYCON_KIND
structure Tycon:
sig
+ structure BindingStrength: BINDING_STRENGTH
+
type t
val admitsEquality: t -> AdmitsEquality.t ref
@@ -23,8 +25,9 @@
val exn: t
val layout: t -> Layout.t
val layoutApp:
- t * (Layout.t * {isChar: bool, needsParen: bool}) vector
- -> Layout.t * {isChar: bool, needsParen: bool}
+ t * (Layout.t
+ * ({isChar: bool} * BindingStrength.t)) vector
+ -> Layout.t * ({isChar: bool} * BindingStrength.t)
val tuple: t
end
Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/type-env.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,10 +84,10 @@
structure Lay =
struct
- type t = Layout.t * {isChar: bool, needsParen: bool}
+ type t = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
fun simple (l: Layout.t): t =
- (l, {isChar = false, needsParen = false})
+ (l, ({isChar = false}, Tycon.BindingStrength.unit))
end
structure UnifyResult =
@@ -370,11 +370,11 @@
Trace.trace ("TypeEnv.tyvarTime", Tyvar.layout, Ref.layout Time.layout) tyvarTime
local
- type z = Layout.t * {isChar: bool, needsParen: bool}
+ type z = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
open Layout
in
fun simple (l: Layout.t): z =
- (l, {isChar = false, needsParen = false})
+ (l, ({isChar = false}, Tycon.BindingStrength.unit))
val dontCare: z = simple (str "_")
fun bracket l = seq [str "[", l, str "]"]
fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
@@ -600,8 +600,9 @@
end
fun makeLayoutPretty (): {destroy: unit -> unit,
- lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}} =
+ lay: t -> Layout.t
+ * ({isChar: bool}
+ * Tycon.BindingStrength.t)} =
let
val str = Layout.str
fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -946,10 +947,9 @@
(NotUnifiable (l, l'),
Unknown (Unknown.new {canGeneralize = true}))
val bracket =
- fn (l, {isChar, needsParen = _}) =>
+ fn (l, ({isChar}, _)) =>
(bracket l,
- {isChar = isChar,
- needsParen = false})
+ ({isChar = isChar}, Tycon.BindingStrength.unit))
fun notUnifiableBracket (l, l') =
notUnifiable (bracket l, bracket l')
fun flexToRecord (fields, spine) =
Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/type-env.sig 2007-01-07 16:33:41 UTC (rev 5014)
@@ -53,8 +53,8 @@
hom: t -> 'a}
val makeLayoutPretty:
unit -> {destroy: unit -> unit,
- lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}}
+ 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/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun 2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun 2007-01-07 16:33:41 UTC (rev 5014)
@@ -59,7 +59,8 @@
then seq [layout elt, str " ref"]
else layout elt
in
- (lay, {isChar = false, needsParen = false})
+ (lay, ({isChar = false},
+ Tycon.BindingStrength.unit))
end))))
end
|
