[MLton-commit] r6106

Vesa Karvonen vesak at mlton.org
Tue Oct 30 03:51:25 PST 2007


Introduced Ops/ops structures/records for sequences to reduce duplication.

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

U   mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ops.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -6,33 +6,35 @@
 
 structure Ops = struct
    datatype 'a wops =
-      W of {wordSize : Int.t,
-            orb : 'a BinOp.t,
-            << : 'a ShiftOp.t,
-            ~>> : 'a ShiftOp.t,
+      W of {<< : 'a ShiftOp.t,
             >> : 'a ShiftOp.t,
             isoWord8 : ('a, Word8.t) Iso.t,
-            isoWord8X : ('a, Word8.t) Iso.t}
+            isoWord8X : ('a, Word8.t) Iso.t,
+            orb : 'a BinOp.t,
+            wordSize : Int.t,
+            ~>> : 'a ShiftOp.t}
 
    datatype 'a iops =
-      I of {precision : Int.t Option.t,
-            maxInt : 'a Option.t,
-            fromInt : Int.t -> 'a,
-            *` : 'a BinOp.t,
+      I of {*` : 'a BinOp.t,
             +` : 'a BinOp.t,
             div : 'a BinOp.t,
-            mod : 'a BinOp.t}
+            fromInt : Int.t -> 'a,
+            maxInt : 'a Option.t,
+            mod : 'a BinOp.t,
+            precision : Int.t Option.t}
+
+   datatype ('elem, 'list, 'result, 'seq, 'slice) sops =
+      S of {foldl : ('elem * 'result -> 'result) -> 'result -> 'seq -> 'result,
+            fromList : 'list -> 'seq,
+            getItem : 'slice -> ('elem * 'slice) Option.t,
+            length : 'seq -> Int.t,
+            sub : 'seq * Int.t -> 'elem,
+            toSlice : 'seq -> 'slice}
 end
 
-functor MkWordOps (Arg : WORD) = struct
-   local
-      open Arg
-   in
-      val ops =
-          Ops.W {wordSize = wordSize, orb = op orb,
-                 << = op <<, ~>> = op ~>>, >> = op >>,
-                 isoWord8 = isoWord8, isoWord8X = isoWord8X}
-   end
+functor MkWordOps (include WORD) = struct
+   val ops = Ops.W {wordSize = wordSize, orb = op orb, << = op <<, ~>> = op ~>>,
+                    >> = op >>, isoWord8 = isoWord8, isoWord8X = isoWord8X}
 end
 
 structure LargeRealWordOps = MkWordOps (CastLargeReal.Bits)
@@ -45,19 +47,45 @@
 *)
 structure Word8Ops = MkWordOps (Word8)
 
-functor MkIntOps (Arg : INTEGER) = struct
-   local
-      open Arg
-   in
-      val ops =
-          Ops.I {precision = precision,
-                 maxInt = maxInt,
-                 fromInt = fromInt,
-                 *` = op *, +` = op +,
-                 div = op div, mod = op mod}
-   end
+functor MkIntOps (include INTEGER) = struct
+   val ops = Ops.I {precision = precision, maxInt = maxInt, fromInt = fromInt,
+                    *` = op *, +` = op +, div = op div, mod = op mod}
 end
 
 structure FixedIntOps = MkIntOps (FixedInt)
 structure IntOps = MkIntOps (Int)
 structure LargeIntOps = MkIntOps (LargeInt)
+
+functor MkSeqOps (structure Seq : sig
+                     type 'a t
+                     val length : 'a t -> Int.t
+                     val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
+                     val fromList : 'a List.t -> 'a t
+                     val sub : 'a t * Int.t -> 'a
+                  end
+                  structure Slice : sig
+                     type 'a t
+                     val full : 'a Seq.t -> 'a t
+                     val getItem : 'a t -> ('a * 'a t) Option.t
+                  end) = struct
+   val ops = Ops.S {length = Seq.length, foldl = Seq.foldl,
+                    toSlice = Slice.full, getItem = Slice.getItem,
+                    fromList = Seq.fromList, sub = Seq.sub}
+end
+
+structure ArrayOps = MkSeqOps (structure Seq = Array and Slice = ArraySlice)
+structure VectorOps = MkSeqOps (structure Seq = Vector and Slice = VectorSlice)
+structure ListOps = MkSeqOps
+  (structure Seq = struct
+      open List
+      val fromList = TopLevel.id
+   end
+   structure Slice = struct
+      open List
+      val full = TopLevel.id
+   end)
+structure StringOps = struct
+   val ops = Ops.S {length = String.length, foldl = String.foldl,
+                    toSlice = Substring.full, getItem = Substring.getc,
+                    fromList = String.fromList, sub = String.sub}
+end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -10,7 +10,7 @@
    infix  0 &
    (* SML/NJ workaround --> *)
 
-   fun seq length sub eq (l, r) = let
+   fun sequ (Ops.S {length, sub, ...}) eq (l, r) = let
       val lL = length l
       val lR = length r
       fun lp i = let
@@ -67,7 +67,7 @@
 
       val list = ListPair.allEq
 
-      fun vector ? = seq Vector.length Vector.sub ?
+      fun vector ? = sequ VectorOps.ops ?
 
       fun array _ = op = : 'a Array.t t
       fun refc  _ = op = : 'a Ref.t t

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -22,7 +22,7 @@
 
    fun iso' bH (a2b, _) = bH o Pair.map (a2b, id)
 
-   fun sequ length sub hashElem (s, {totWidth, maxDepth}) = let
+   fun sequ (Ops.S {length, sub, ...}) hashElem (s, {totWidth, maxDepth}) = let
       val n = length s
       val h = Word.fromInt n
    in
@@ -137,11 +137,11 @@
             end
       end
 
-      fun array  aT = sequ Array.length  Array.sub  (getT aT)
-      fun vector aT = sequ Vector.length Vector.sub (getT aT)
+      fun array  aT = sequ  ArrayOps.ops (getT aT)
+      fun vector aT = sequ VectorOps.ops (getT aT)
 
       val char = prim (Word.fromInt o ord)
-      val string = sequ String.length String.sub char
+      val string = sequ StringOps.ops char
 
       fun exn (e, {maxDepth, totWidth}) =
           if maxDepth = 0 then 0wx1A35B599

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -15,7 +15,7 @@
 
    fun lift (cmp : 'a Cmp.t) : 'a t = IN (cmp o #2)
 
-   fun sequ {toSlice, getItem} (IN aO) =
+   fun sequ (Ops.S {toSlice, getItem, ...}) (IN aO) =
        IN (fn (e, (l, r)) => let
                  fun lp (e, l, r) =
                      case getItem l & getItem r
@@ -116,12 +116,10 @@
       fun regExn0 _ = regExn unit
       fun regExn1 _ = regExn o getT
 
-      fun array aT = cyclic (Arg.Open.array ignore aT)
-                            (sequ {toSlice = ArraySlice.full,
-                                   getItem = ArraySlice.getItem} (getT aT))
-      fun list aT = sequ {toSlice = id, getItem = List.getItem} (getT aT)
-      fun vector aT = sequ {toSlice = VectorSlice.full,
-                            getItem = VectorSlice.getItem} (getT aT)
+      fun array aT =
+          cyclic (Arg.Open.array ignore aT) (sequ ArrayOps.ops (getT aT))
+      fun list aT = sequ ListOps.ops (getT aT)
+      fun vector aT = sequ VectorOps.ops (getT aT)
 
       fun refc aT = cyclic (Arg.Open.refc ignore aT) (iso aT (!, undefined))
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -327,7 +327,8 @@
                            wr = writeWhole,
                            sz = NONE})
 
-   fun seq {length, toSlice, getItem, fromList} (P {rd = aR, wr = aW, ...}) =
+   fun sequ (Ops.S {length, toSlice, getItem, fromList, ...})
+            (P {rd = aR, wr = aW, ...}) =
        P {rd = let
              open I
              fun lp (0, es) = return (fromList (rev es))
@@ -347,11 +348,7 @@
           end,
           sz = NONE : OptInt.t}
 
-   val string =
-       share (Arg.Open.string ())
-             (seq {length = String.length, toSlice = Substring.full,
-                   getItem = Substring.getc, fromList = String.fromList}
-                  char)
+   val string = share (Arg.Open.string ()) (sequ StringOps.ops char)
 
    val c2b = Byte.charToByte
    val b2c = Byte.byteToChar
@@ -621,15 +618,10 @@
          end
 
          fun list aT =
-             share (Arg.Open.list ignore aT)
-                   (seq {length = List.length, toSlice = id,
-                         getItem = List.getItem, fromList = id} (getT aT))
+             share (Arg.Open.list ignore aT) (sequ ListOps.ops (getT aT))
 
          fun vector aT =
-             share (Arg.Open.vector ignore aT)
-                   (seq {length = Vector.length, toSlice = VectorSlice.full,
-                         getItem = VectorSlice.getItem,
-                         fromList = Vector.fromList} (getT aT))
+             share (Arg.Open.vector ignore aT) (sequ VectorOps.ops (getT aT))
 
          val exn : Exn.t t =
              P {rd = let

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -182,7 +182,7 @@
                                          of SOME (SOME u) => u <^> equals
                                           | _             => empty) <^> d))
 
-      fun sequ style toSlice getItem aP
+      fun sequ style (Ops.S {toSlice, getItem, ...}) aP
                (e as E ({fmt = Fmt.T r, ...}, _), a) = let
          fun lp (n, d, s) =
              case getItem s
@@ -377,10 +377,9 @@
              cyclic (Arg.Open.refc ignore aT) o flip inj ! |< C1 ctorRef aT
          fun array aT =
              cyclic (Arg.Open.array ignore aT) |<
-                    sequ hashParens ArraySlice.full ArraySlice.getItem (T aT)
-         fun vector aT =
-             sequ hashBrackets VectorSlice.full VectorSlice.getItem (T aT)
-         fun list aT = sequ brackets id List.getItem (T aT)
+                    sequ hashParens ArrayOps.ops (T aT)
+         fun vector aT = sequ hashBrackets VectorOps.ops (T aT)
+         fun list aT = sequ brackets ListOps.ops (T aT)
 
          fun op --> _ = const (ATOMIC, txtFn)
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -12,7 +12,7 @@
    
    datatype 'a t = IN of Univ.t * Univ.t BinOp.t * 'a -> Univ.t
 
-   fun sequ toSlice getItem (IN xR) =
+   fun sequ (Ops.S {toSlice, getItem, ...}) (IN xR) =
        IN (fn (z, p, xs) => let
                  fun lp (s, xs) =
                      case getItem xs
@@ -70,9 +70,9 @@
       fun regExn0 _ _ = ()
       fun regExn1 _ _ _ = ()
 
-      fun list   ? = sequ             id          List.getItem ?
-      fun vector ? = sequ VectorSlice.full VectorSlice.getItem ?
-      fun array  ? = sequ  ArraySlice.full  ArraySlice.getItem ?
+      fun list   ? = sequ   ListOps.ops ?
+      fun vector ? = sequ VectorOps.ops ?
+      fun array  ? = sequ  ArrayOps.ops ?
 
       fun refc (IN aR) = IN (fn (z, p, r) => aR (z, p, !r))
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -15,7 +15,7 @@
 
    fun lift (eq : 'a BinPr.t) : 'a t = IN (eq o #2)
 
-   fun sequ {toSlice, getItem} (IN aE) =
+   fun sequ (Ops.S {toSlice, getItem, ...}) (IN aE) =
        IN (fn (e, (l, r)) => let
                  fun lp (e, l, r) =
                      case getItem l & getItem r
@@ -109,12 +109,10 @@
       fun regExn0 _ (e, p) = regExn unit (const e, p)
       fun regExn1 _ = regExn o getT
 
-      fun array aT = cyclic (Arg.Open.array ignore aT)
-                            (sequ {toSlice = ArraySlice.full,
-                                   getItem = ArraySlice.getItem} (getT aT))
-      fun list aT = sequ {toSlice = id, getItem = List.getItem} (getT aT)
-      fun vector aT = sequ {toSlice = VectorSlice.full,
-                            getItem = VectorSlice.getItem} (getT aT)
+      fun array aT =
+          cyclic (Arg.Open.array ignore aT) (sequ ArrayOps.ops (getT aT))
+      fun list aT = sequ ListOps.ops (getT aT)
+      fun vector aT = sequ VectorOps.ops (getT aT)
 
       fun refc aT = cyclic (Arg.Open.refc ignore aT) (iso aT (!, undefined))
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml	2007-10-29 12:20:15 UTC (rev 6105)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml	2007-10-30 11:51:23 UTC (rev 6106)
@@ -24,7 +24,7 @@
 
    val wordSize = bytes Word.wordSize
 
-   fun sequ length foldl =
+   fun sequ (Ops.S {length, foldl, ...}) =
     fn STATIC s  => (fn (_, a) => (s * length a + 2 * wordSize))
      | DYNAMIC f => (fn (e, a) =>
                         foldl (fn (x, s) => s + f (e, x)) (2 * wordSize) a)
@@ -137,11 +137,11 @@
                           foldl (fn (x, s) => s + wordSize + f (e, x))
                                 wordSize xs)
 
-      fun vector xT = DYNAMIC (sequ Vector.length Vector.foldl (getT xT))
+      fun vector xT = DYNAMIC (sequ VectorOps.ops (getT xT))
 
       fun array xT =
           cyclic (Arg.Open.array ignore xT)
-                 (sequ Array.length Array.foldl (getT xT))
+                 (sequ ArrayOps.ops (getT xT))
 
       fun refc xT =
           cyclic (Arg.Open.refc ignore xT)




More information about the MLton-commit mailing list