[MLton] show-basis parentheses hack
Vesa Karvonen
vesa.karvonen@cs.helsinki.fi
Fri, 16 Sep 2005 20:29:17 +0300
I've been using show-basis to help construct signatures for some structures.
Unfortunately, the output of show-basis contains redundant parentheses and
I need to spend extra time to remove the redundant parentheses.
The current layout/pretty printing algorithm has a flag "needsParen", but it
does not provide enough information to eliminate all redundant parentheses.
I drafted an alternative algorithm to eliminate redundant parentheses.
Here is an example of a specification produced by the current algorithm:
val O: (('a * 'b) * 'c)
-> (('a -> (('b * 'd) -> 'e)) -> ('d -> (((('a * 'e) * 'c) -> 'f) -> 'f)))
As you can see, the above contains lots of redundant parentheses. For
instance, all tuples are parenthesized and curried functions are parenthesized.
(The current algorithm also produces redundant parentheses in some other cases.)
Below is the specification produced by the new algorithm:
val O: ('a * 'b) * 'c
-> ('a -> 'b * 'd -> 'e) -> 'd -> (('a * 'e) * 'c -> 'f) -> 'f
The implementation is a bit hacky. I'm not entirely sure about where new "plain
old" datatypes should be placed (in the MLton framework). Since the new datatype
I introduced is required in multiple different places, I just (lazily) moved the
datatype to a top-level structure BS (I intentionally chose an ugly name) and
exported the structure in the MLB file. (If you think that the algorithm is
otherwise worth incorporating into MLton, I'll be happy to restructure the
implementation to conform to MLton conventions.)
Below is the patch for the hacky draft implementation of the new algorithm. The
core algorithm is in the "prim-tycons.fun" file. The rest is just about passing
the data to the algorithm.
Index: mlton/atoms/hash-type.fun
===================================================================
--- mlton/atoms/hash-type.fun (revision 4095)
+++ mlton/atoms/hash-type.fun (working copy)
@@ -85,7 +85,7 @@
#1 (hom {con = Tycon.layoutApp,
ty = ty,
var = fn a => (Tyvar.layout a, {isChar = false,
- needsParen = false})})
+ bindingStrength = BS.Unit})})
val toString = Layout.toString o layout
Index: mlton/ssa/sources.mlb
===================================================================
--- mlton/ssa/sources.mlb (revision 4095)
+++ mlton/ssa/sources.mlb (working copy)
@@ -7,6 +7,7 @@
*)
local
+ ../ast/sources.mlb
../../lib/mlton/sources.mlb
../atoms/sources.mlb
../control/sources.mlb
Index: mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/ssa/ssa-tree2.fun (revision 4095)
+++ mlton/ssa/ssa-tree2.fun (working copy)
@@ -59,7 +59,7 @@
then seq [layout elt, str " ref"]
else layout elt
in
- (lay, {isChar = false, needsParen = false})
+ (lay, {isChar = false, bindingStrength = BS.Unit})
end))))
end
Index: mlton/ast/prim-tycons.sig
===================================================================
--- mlton/ast/prim-tycons.sig (revision 4095)
+++ mlton/ast/prim-tycons.sig (working copy)
@@ -27,6 +27,14 @@
val layout: t -> Layout.t
end
+structure BS =
+ struct
+ datatype binding_strength =
+ Arrow
+ | Tuple
+ | Unit
+ end
+
signature PRIM_TYCONS =
sig
include PRIM_TYCONS_SUBSTRUCTS
@@ -52,8 +60,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: BS.binding_strength}) vector
+ -> Layout.t * {isChar: bool, bindingStrength: BS.binding_strength}
val list: tycon
val pointer: tycon
val prims: (tycon * Kind.t * AdmitsEquality.t) list
Index: mlton/ast/prim-tycons.fun
===================================================================
--- mlton/ast/prim-tycons.fun (revision 4095)
+++ mlton/ast/prim-tycons.fun (working copy)
@@ -105,7 +105,7 @@
@ primChars @ primInts @ primReals @ primWords
fun layoutApp (c: t,
- args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
+ args: (Layout.t * {isChar: bool, bindingStrength: BS.binding_strength}) vector) =
let
local
open Layout
@@ -114,37 +114,48 @@
val seq = seq
val str = str
end
- fun maybe (l, {isChar = _, needsParen}) =
- if needsParen
- then Layout.paren l
- else l
+ datatype binding_context =
+ ArrowLhs
+ | ArrowRhs
+ | TupleElem
+ | Tyseq1
+ | TyseqN
+ fun maybe bindingContext (l, {isChar = _, bindingStrength}) =
+ case (bindingStrength, bindingContext) of
+ (BS.Unit, _) => l
+ | (BS.Tuple, ArrowLhs) => l
+ | (BS.Tuple, ArrowRhs) => l
+ | (BS.Tuple, TyseqN) => l
+ | (BS.Arrow, ArrowRhs) => l
+ | (BS.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, bindingStrength = BS.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, bindingStrength = BS.Arrow})
else if equals (c, tuple)
then if 0 = Vector.length args
- then (str "unit", {isChar = false, needsParen = false})
+ then (str "unit", {isChar = false, bindingStrength = BS.Unit})
else (mayAlign (Layout.separateLeft
- (Vector.toListMap (args, maybe), "* ")),
- {isChar = false, needsParen = true})
+ (Vector.toListMap (args, maybe TupleElem), "* ")),
+ {isChar = false, bindingStrength = BS.Tuple})
else if equals (c, vector)
then if #isChar (#2 (Vector.sub (args, 0)))
- then (str "string", {isChar = false, needsParen = false})
+ then (str "string", {isChar = false, bindingStrength = BS.Unit})
else normal ()
else normal ()
end
Index: mlton/ast/sources.mlb
===================================================================
--- mlton/ast/sources.mlb (revision 4095)
+++ mlton/ast/sources.mlb (working copy)
@@ -67,6 +67,8 @@
signature TYVAR
signature WORD_SIZE
+ structure BS
+
functor AdmitsEquality
functor Ast
functor Field
Index: mlton/elaborate/interface.sig
===================================================================
--- mlton/elaborate/interface.sig (revision 4095)
+++ mlton/elaborate/interface.sig (working copy)
@@ -23,8 +23,8 @@
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: BS.binding_strength}) vector
+ -> Layout.t * {isChar: bool, bindingStrength: BS.binding_strength}
val tuple: t
end
Index: mlton/elaborate/interface.fun
===================================================================
--- mlton/elaborate/interface.fun (revision 4095)
+++ mlton/elaborate/interface.fun (working copy)
@@ -144,7 +144,7 @@
("id", TyconId.layout id)]
end
- fun layoutApp (t, _) = (layout t, {isChar = false, needsParen = false})
+ fun layoutApp (t, _) = (layout t, {isChar = false, bindingStrength = BS.Unit})
val copies: copy list ref = ref []
@@ -247,7 +247,7 @@
local
open Layout
- fun simple l = (l, {isChar = false, needsParen = false})
+ fun simple l = (l, {isChar = false, bindingStrength = BS.Unit})
fun loop t =
case t of
Con (c, ts) => Tycon.layoutApp (c, Vector.map (ts, loop))
Index: mlton/elaborate/type-env.sig
===================================================================
--- mlton/elaborate/type-env.sig (revision 4095)
+++ mlton/elaborate/type-env.sig (working copy)
@@ -52,7 +52,7 @@
val makeLayoutPretty:
unit -> {destroy: unit -> unit,
lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}}
+ bindingStrength: BS.binding_strength}}
(* 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.
Index: mlton/elaborate/type-env.fun
===================================================================
--- mlton/elaborate/type-env.fun (revision 4095)
+++ mlton/elaborate/type-env.fun (working copy)
@@ -84,10 +84,10 @@
structure Lay =
struct
- type t = Layout.t * {isChar: bool, needsParen: bool}
+ type t = Layout.t * {isChar: bool, bindingStrength: BS.binding_strength}
fun simple (l: Layout.t): t =
- (l, {isChar = false, needsParen = false})
+ (l, {isChar = false, bindingStrength = BS.Unit})
end
structure UnifyResult =
@@ -369,11 +369,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, bindingStrength: BS.binding_strength}
open Layout
in
fun simple (l: Layout.t): z =
- (l, {isChar = false, needsParen = false})
+ (l, {isChar = false, bindingStrength = BS.Unit})
val dontCare: z = simple (str "_")
fun bracket l = seq [str "[", l, str "]"]
fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
@@ -600,7 +600,7 @@
fun makeLayoutPretty (): {destroy: unit -> unit,
lay: t -> Layout.t * {isChar: bool,
- needsParen: bool}} =
+ bindingStrength: BS.binding_strength}} =
let
val str = Layout.str
fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -933,10 +933,10 @@
(NotUnifiable (l, l'),
Unknown (Unknown.new {canGeneralize = true}))
val bracket =
- fn (l, {isChar, needsParen = _}) =>
+ fn (l, {isChar, bindingStrength = _}) =>
(bracket l,
{isChar = isChar,
- needsParen = false})
+ bindingStrength = BS.Unit})
fun notUnifiableBracket (l, l') =
notUnifiable (bracket l, bracket l')
fun flexToRecord (fields, spine) =
Index: mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/elaborate/elaborate-env.fun (revision 4095)
+++ mlton/elaborate/elaborate-env.fun (working copy)
@@ -82,7 +82,7 @@
fun explainDoesNotAdmitEquality (t: t): Layout.t =
let
open Layout
- val wild = (str "_", {isChar = false, needsParen = false})
+ val wild = (str "_", {isChar = false, bindingStrength = BS.Unit})
fun con (c, ts) =
let
fun keep {showInside: bool} =
@@ -126,7 +126,7 @@
seq [Field.layout f, str ": ", z] :: ac),
",")),
str "}"],
- {isChar = false, needsParen = false})
+ {isChar = false, bindingStrength = BS.Unit})
end
| SOME v =>
Tycon.layoutApp