[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