[MLton-commit] r5832

[Vesa Karvonen]

Added a WithDebug functor for checking the uniqueness of labels and
constructors.

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

U   mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A   mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U   mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U   mltonlib/trunk/com/ssh/generic/unstable/public/export.sml

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm	2007-08-07 18:19:06 UTC (rev 5831)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm	2007-08-07 19:09:19 UTC (rev 5832)
@@ -42,6 +42,7 @@
    ../../sml-syntax.sml
    ../../value/arbitrary.sml
    ../../value/data-rec-info.sml
+   ../../value/debug.sml
    ../../value/dynamic.sml
    ../../value/eq.sml
    ../../value/hash.sml

Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml	2007-08-07 18:19:06 UTC (rev 5831)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml	2007-08-07 19:09:19 UTC (rev 5832)
@@ -0,0 +1,79 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithDebug (Arg : OPEN_GENERIC) : OPEN_GENERIC = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   (* SML/NJ workaround --> *)
+
+   open Generics
+
+   (* XXX Consider an asymptotically more efficient set representation. *)
+
+   fun add1 kind (x, xs) =
+       if List.exists (eq x) xs
+       then fail (concat ["Duplicate ", kind, "s: ", x])
+       else x::xs
+
+   fun addN kind (xs, ys) = foldl (add1 kind) xs ys
+
+   structure Check =
+      LayerGenericRep (structure Outer = Arg.Rep
+                       structure Closed = struct
+                          type 'a t = Unit.t
+                          type 'a s = String.t List.t
+                          type ('a, 'k) p = String.t List.t
+                       end)
+
+   structure Layered = LayerGeneric
+     (structure Outer = Arg and Result = Check and Rep = Check.Closed
+
+      val iso        = const
+      val isoProduct = const
+      val isoSum     = const
+
+      fun op *` ? = addN "label" ?
+      fun T () = []
+      fun R l () = [Label.toString 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]
+      val data = ignore
+
+      val Y = Tie.id ()
+
+      val op --> = ignore
+
+      val exnCons : String.t List.t Ref.t = ref []
+      fun regExn cs _ = exnCons := addN "exception constructor" (!exnCons, cs)
+      val exn = ()
+
+      val list   = ignore
+      val vector = ignore
+      val array  = ignore
+      val refc   = ignore
+
+      val largeInt  = ()
+      val largeReal = ()
+      val largeWord = ()
+
+      val bool   = ()
+      val char   = ()
+      val int    = ()
+      val real   = ()
+      val string = ()
+      val word   = ()
+
+      val word8  = ()
+      val word32 = ()
+      val word64 = ())
+
+   open Layered
+end


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-08-07 18:19:06 UTC (rev 5831)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-08-07 19:09:19 UTC (rev 5832)
@@ -74,6 +74,8 @@
          public/value/arbitrary.sig
          detail/value/arbitrary.sml
 
+         detail/value/debug.sml
+
          public/value/dynamic.sig
          detail/value/dynamic.sml
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml	2007-08-07 18:19:06 UTC (rev 5831)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml	2007-08-07 19:09:19 UTC (rev 5832)
@@ -149,6 +149,14 @@
 functor WithDataRecInfo (Arg : OPEN_GENERIC) : DATA_REC_INFO_GENERIC =
    WithDataRecInfo (Arg)
 
+functor WithDebug (Arg : OPEN_GENERIC) : OPEN_GENERIC = WithDebug (Arg)
+(**
+ * Checks dynamically that
+ * - labels are unique within each record,
+ * - constructors are unique within each datatype, and
+ * - exception constructors are globally unique.
+ *)
+
 functor WithDynamic (Arg : OPEN_GENERIC) : DYNAMIC_GENERIC = WithDynamic (Arg)
 
 functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = WithEq (Arg)