[MLton-commit] r5014

Vesa Karvonen vesak at mlton.org
Sun Jan 7 08:34:08 PST 2007


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
 




More information about the MLton-commit mailing list