[MLton-commit] r5625

Vesa Karvonen vesak at mlton.org
Sat Jun 16 02:10:52 PDT 2007


Minor tweaks.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -119,11 +119,9 @@
                      cog = fn f => fn g =>
                               aGen >>= (fn a => universally (bCog (f a)) g)}) ?
 
-   fun exn ? = let
-      val e = Fail "Arbitrary.exn not supported yet"
-   in
-      nullary Arg.exn (IN {gen = G.return Empty, cog = raising e})
-   end ?
+   fun exn ? =
+       nullary Arg.exn (IN {gen = G.return Empty,
+                            cog = failing "Arbitrary.exn unsupported"}) ?
 
    fun regExn ef = Arg.regExn (ef o Pair.snd)
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-structure Dummy :> DUMMY_GENERIC = struct
+local
    (* <-- SML/NJ workaround *)
    open TopLevel
    infix  7 *`
    infix  6 +`
    infix  0 &
-   infixr 0 -->
    (* SML/NJ workaround --> *)
 
-   structure Opened = OpenGeneric
-     (structure Rep = struct
+   structure Dummy : CLOSED_GENERIC = struct
+      structure Rep = struct
          type 'a t = 'a Option.t
          type 'a s = 'a t
          type ('a, 'k) p = 'a t
@@ -32,11 +31,7 @@
 
       fun Y ? = Tie.pure (const (NONE, id)) ?
 
-      local
-         val e = Fail "Dummy.-->"
-      in
-         fun _ --> _ = SOME (raising e)
-      end
+      fun op --> _ = SOME (failing "Dummy.-->")
 
       val exn = SOME Empty
       fun regExn _ _ = ()
@@ -77,25 +72,29 @@
 
       fun C0 _ = unit
       fun C1 _ = id
-      val data = id)
+      val data = id
+   end
 
-   open Opened
+   structure Dummy : OPEN_GENERIC = OpenGeneric (Dummy)
+in
+   structure Dummy :> DUMMY_GENERIC = struct
+      open Dummy
 
-   structure Dummy = Rep
-   exception Dummy
+      structure Dummy = Rep
+      exception Dummy
 
-   fun dummy (vo, _) =
-       case vo of
-          SOME v => v
-        | NONE   => raise Dummy
+      val dummy : ('a, 'x) Dummy.t -> 'a =
+          fn (SOME v, _) => v
+           | (NONE,   _) => raise Dummy
 
-   fun noDummy (_, x) = (NONE, x)
+      fun noDummy (_, x) = (NONE, x)
+   end
 end
 
-functor WithDummy (Outer : OPEN_GENERIC) : DUMMY_GENERIC = struct
-   structure Joined = JoinGenerics (structure Outer = Outer and Inner = Dummy)
+functor WithDummy (Arg : OPEN_GENERIC) : DUMMY_GENERIC = struct
+   structure Joined = JoinGenerics (structure Outer = Arg and Inner = Dummy)
    open Dummy Joined
    structure Dummy = Rep
-   val dummy = fn ? => dummy (Outer.Rep.getT ?)
-   val noDummy = fn ? => Outer.Rep.mapT noDummy ?
+   val dummy = fn ? => dummy (Arg.Rep.getT ?)
+   val noDummy = fn ? => Arg.Rep.mapT noDummy ?
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-structure Eq :> EQ_GENERIC = struct
+local
    (* <-- SML/NJ workaround *)
    open TopLevel
    infix  7 *`
    infix  6 +`
    infix  0 &
-   infixr 0 -->
    (* SML/NJ workaround --> *)
 
-   structure Opened = OpenGeneric
-     (structure Rep = struct
+   structure Eq : CLOSED_GENERIC = struct
+      structure Rep = struct
          type 'a t = 'a BinPr.t
          type 'a s = 'a t
          type ('a, 'k) p = 'a t
@@ -27,11 +26,7 @@
 
       val Y = Tie.function
 
-      local
-         val e = Fail "Eq.--> not supported"
-      in
-         fun _ --> _ = raising e
-      end
+      fun op --> _ = failing "Eq.--> unsupported"
 
       val exn : Exn.t Rep.t Ref.t = ref GenericsUtil.failExnSq
       fun regExn t (_, prj) =
@@ -80,21 +75,24 @@
 
       fun C0 _ = unit
       fun C1 _ = id
-      val data = id)
+      val data = id
+   end
 
-   open Opened
-
-   structure Eq = Rep
-
-   val eq = Pair.fst
-   fun notEq (eq, _) = negate eq
+   structure Eq : OPEN_GENERIC = OpenGeneric (Eq)
+in
+   structure Eq :> EQ_GENERIC = struct
+      open Eq
+      structure Eq = Rep
+      val eq : ('a, 'x) Eq.t -> 'a BinPr.t = Pair.fst
+      fun notEq (eq, _) = negate eq
+   end
 end
 
-functor WithEq (Outer : OPEN_GENERIC) : EQ_GENERIC = struct
-   structure Joined = JoinGenerics (structure Outer = Outer and Inner = Eq)
+functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = struct
+   structure Joined = JoinGenerics (structure Outer = Arg and Inner = Eq)
    open Eq Joined
    structure Eq = Rep
-   fun mk f = f o Outer.Rep.getT
+   fun mk f = f o Arg.Rep.getT
    val eq    = fn ? => mk eq    ?
    val notEq = fn ? => mk notEq ?
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-structure Ord :> ORD_GENERIC = struct
+local
    (* <-- SML/NJ workaround *)
    open TopLevel
    infix  7 *`
    infix  6 +`
    infix  0 &
-   infixr 0 -->
    (* SML/NJ workaround --> *)
 
-   structure Opened = OpenGeneric
-     (structure Rep = struct
+   structure Ord : CLOSED_GENERIC = struct
+      structure Rep = struct
          type 'a t = 'a Cmp.t
          type 'a s = 'a t
          type ('a, 'k) p = 'a t
@@ -28,11 +27,7 @@
 
       val Y = Tie.function
 
-      local
-         val e = Fail "Compare.--> not supported"
-      in
-         fun _ --> _ = raising e
-      end
+      fun op --> _ = failing "Compare.--> unsupported"
 
      (* XXX It is also possible to implement exn so that compare provides
       * a reasonable answer as long as at least one of the exception
@@ -85,18 +80,21 @@
 
       fun C0 _ = unit
       fun C1 _ = id
-      val data = id)
+      val data = id
+   end
 
-   open Opened
-
-   structure Ord = Rep
-
-   val compare = Pair.fst
+   structure Ord : OPEN_GENERIC = OpenGeneric (Ord)
+in
+   structure Ord :> ORD_GENERIC = struct
+      open Ord
+      structure Ord = Rep
+      val compare : ('a, 'x) Ord.t -> 'a Cmp.t = Pair.fst
+   end
 end
 
-functor WithOrd (Outer : OPEN_GENERIC) : ORD_GENERIC = struct
-   structure Joined = JoinGenerics (structure Outer = Outer and Inner = Ord)
+functor WithOrd (Arg : OPEN_GENERIC) : ORD_GENERIC = struct
+   structure Joined = JoinGenerics (structure Outer = Arg and Inner = Ord)
    open Ord Joined
    structure Ord = Rep
-   val compare = fn ? => compare (Outer.Rep.getT ?)
+   val compare = fn ? => compare (Arg.Rep.getT ?)
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -9,7 +9,7 @@
 (* XXX parameters for pretty printing? *)
 (* XXX parameters for depth, length, etc... for showing only partial data *)
 
-structure Show :> SHOW_GENERIC = struct
+local
    (* <-- SML/NJ workaround *)
    open TopLevel
    infix  7 *`
@@ -24,8 +24,8 @@
    infixr 0 -->
    (* SML/NJ workaround --> *)
 
-   structure Opened = OpenGeneric
-     (local
+   structure Show : CLOSED_GENERIC = struct
+      local
          open Prettier
          type u = Bool.t * t
          fun atomic    doc = (true,  doc)
@@ -187,20 +187,24 @@
       val word8  = mkWord Word8.toString
    (* val word16 = mkWord Word16.toString (* Word16 not provided by SML/NJ *) *)
       val word32 = mkWord Word32.toString
-      val word64 = mkWord Word64.toString)
+      val word64 = mkWord Word64.toString
+   end
 
-   open Opened
-
-   structure Show = Rep
-
-   fun layout (t, _) x = Pair.snd (t ([], x))
-   fun show m t = Prettier.pretty m o layout t
+   structure Show : OPEN_GENERIC = OpenGeneric (Show)
+in
+   structure Show :> SHOW_GENERIC = struct
+      open Show
+      structure Show = Rep
+      val layout : ('a, 'x) Show.t -> 'a -> Prettier.t =
+          fn (t, _) => Pair.snd o [] <\ t
+      fun show m t = Prettier.pretty m o layout t
+   end
 end
 
-functor WithShow (Outer : OPEN_GENERIC) : SHOW_GENERIC = struct
-   structure Joined = JoinGenerics (structure Outer = Outer and Inner = Show)
+functor WithShow (Arg : OPEN_GENERIC) : SHOW_GENERIC = struct
+   structure Joined = JoinGenerics (structure Outer = Arg and Inner = Show)
    open Joined
-   fun layout ? = Show.layout (Outer.Rep.getT ?)
-   fun show m = Show.show m o Outer.Rep.getT
+   fun layout ? = Show.layout (Arg.Rep.getT ?)
+   fun show m = Show.show m o Arg.Rep.getT
    structure Show = Rep
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml	2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml	2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,7 +4,7 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-structure TypeInfo :> TYPE_INFO_GENERIC = struct
+local
    (* <-- SML/NJ workaround *)
    open TopLevel
    infix  7 *`
@@ -61,8 +61,8 @@
       List.revAppend (lp ([], ys))
    end
 
-   structure Opened = OpenGeneric
-     (structure Rep = struct
+   structure TypeInfo : CLOSED_GENERIC = struct
+      structure Rep = struct
          type 'a t = t
          type 'a s = s
          type ('a, 'k) p = p
@@ -148,39 +148,43 @@
       fun C1 _ (INT {base, exn, recs, ...}) =
           INS {alts = 1, base = base, exn = exn, recs = recs}
       fun data (INS {base, exn, recs, ...}) =
-          INT {base = base, exn = exn, pure = true, recs = recs})
+          INT {base = base, exn = exn, pure = true, recs = recs}
+   end
 
-   open Opened
+   structure TypeInfo : OPEN_GENERIC = OpenGeneric (TypeInfo)
+in
+   structure TypeInfo :> TYPE_INFO_GENERIC = struct
+      open TypeInfo
 
-   structure TypeInfo = Rep
+      structure TypeInfo = Rep
 
-   fun out (INT r, _) = r
+      fun out (INT r, _) = r
+      fun hasExn       ? = (#exn o out) ?
+      fun hasRecData   ? = (not o null o #recs o out) ?
+      fun isRefOrArray ? = (not o #pure o out) ?
+      fun canBeCyclic  ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
 
-   fun hasExn ? = (#exn o out) ?
-   fun hasRecData ? = (not o null o #recs o out) ?
-   fun isRefOrArray ? = (not o #pure o out) ?
-   fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
+      fun out (INS r, _) = r
+      fun hasBaseCase  ? = (#base o out) ?
+      fun numAlts      ? = (#alts o out) ?
 
-   fun out (INS r, _) = r
-   fun numAlts ? = (#alts o out) ?
-   fun hasBaseCase ? = (#base o out) ?
-
-   fun out (INP r, _) = r
-   fun numElems ? = (#elems o out) ?
+      fun out (INP r, _) = r
+      fun numElems     ? = (#elems o out) ?
+   end
 end
 
-functor WithTypeInfo (Outer : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
-   structure Joined = JoinGenerics (structure Outer = Outer and Inner = TypeInfo)
+functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
+   structure Joined = JoinGenerics (structure Outer = Arg and Inner = TypeInfo)
    open TypeInfo Joined
    structure TypeInfo = Rep
-   fun mk f = f o Outer.Rep.getT
+   fun mk f = f o Arg.Rep.getT
    val canBeCyclic  = fn ? => mk canBeCyclic  ?
    val hasExn       = fn ? => mk hasExn       ?
    val hasRecData   = fn ? => mk hasRecData   ?
    val isRefOrArray = fn ? => mk isRefOrArray ?
-   fun mk f = f o Outer.Rep.getS
+   fun mk f = f o Arg.Rep.getS
    val hasBaseCase  = fn ? => mk hasBaseCase  ?
    val numAlts      = fn ? => mk numAlts      ?
-   fun mk f = f o Outer.Rep.getP
+   fun mk f = f o Arg.Rep.getP
    val numElems     = fn ? => mk numElems     ?
 end




More information about the MLton-commit mailing list