[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