[MLton-commit] r6370

[Vesa Karvonen]

Check constructor and label syntax only in the Debug generic.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U   mltonlib/trunk/com/ssh/generic/unstable/lib.mlb

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml	2008-01-31 22:30:59 UTC (rev 6369)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/framework/generics.sml	2008-02-01 02:25:48 UTC (rev 6370)
@@ -10,7 +10,7 @@
    (* SML/NJ workaround --> *)
 
    structure Label = struct
-      type t = String.t
+      open String
       val toString = id
    end
 
@@ -19,10 +19,6 @@
    structure Record = Unit
    structure Tuple = Unit
 
-   local
-      fun mk p v = if p v then v else fail "syntax error"
-   in
-      val L = mk SmlSyntax.isLabel
-      val C = mk SmlSyntax.isLongId
-   end
+   val L = id
+   val C = id
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml	2008-01-31 22:30:59 UTC (rev 6369)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml	2008-02-01 02:25:48 UTC (rev 6370)
@@ -9,8 +9,6 @@
    open TopLevel
    (* SML/NJ workaround --> *)
 
-   open Generics
-
    (* XXX Consider an asymptotically more efficient set representation. *)
 
    fun add1 kind (x, xs) =
@@ -20,8 +18,17 @@
 
    fun addN kind (xs, ys) = foldl (add1 kind) xs ys
 
+   local
+      fun mk p k toString x =
+          case toString x
+           of s => if p s then s else fails ["Not a ", k, ": ", s]
+   in
+      val con   = mk SmlSyntax.isLongId "constructor" Generics.Con.toString
+      val label = mk SmlSyntax.isLabel  "label"     Generics.Label.toString
+   end
+
    val exns : String.t List.t Ref.t = ref []
-   fun regExn c = exns := add1 "exception constructor" (Con.toString c, !exns)
+   fun regExn c = exns := add1 "exception constructor" (con c, !exns)
 
    structure DebugRep = LayerRep
      (open Arg
@@ -38,14 +45,14 @@
 
       fun op *` ? = addN "label" ?
       fun T () = []
-      fun R l () = [Label.toString l]
+      fun R l () = [label l]
       val tuple  = ignore
       val record = ignore
 
       fun op +` ? = addN "constructor" ?
       val unit = ()
-      fun C0 c = [Con.toString c]
-      fun C1 c () = [Con.toString c]
+      fun C0 c = [con c]
+      fun C1 c () = [con c]
       val data = ignore
 
       val Y = Tie.id ()

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2008-01-31 22:30:59 UTC (rev 6369)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2008-02-01 02:25:48 UTC (rev 6370)
@@ -23,11 +23,7 @@
          (* Support *)
 
          public/framework/generics.sig
-         local
-            detail/util/sml-syntax.sml
-         in
-            detail/framework/generics.sml
-         end
+         detail/framework/generics.sml
 
          public/framework/ty.sig
          detail/framework/ty.sml
@@ -81,7 +77,11 @@
          public/value/arbitrary.sig
          detail/value/arbitrary.sml
 
-         detail/value/debug.sml
+         local
+            detail/util/sml-syntax.sml
+         in
+            detail/value/debug.sml
+         end
 
          public/value/dynamic.sig
          detail/value/dynamic.sml