[MLton-commit] r5990
Vesa Karvonen
vesak at mlton.org
Sat Sep 1 16:24:57 PDT 2007
Seq using HashMap environment.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-01 23:20:17 UTC (rev 5989)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-01 23:24:55 UTC (rev 5990)
@@ -4,95 +4,110 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithSeq (Arg : OPEN_CASES) : SEQ_CASES = struct
+functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 4 <\
infix 0 &
(* SML/NJ workaround --> *)
- type e = Univ.t List.t
- type 'a t = e * 'a Sq.t -> e * Bool.t
+ type e = (HashUniv.t, HashUniv.t) HashMap.t
+ type 'a t = e * 'a Sq.t -> e Option.t
- fun lift (eq : 'a BinPr.t) : 'a t = Pair.map (id, eq)
+ fun lift (eq : 'a BinPr.t) : 'a t =
+ fn (e, xy) => if eq xy then SOME e else NONE
fun sequ {toSlice, getItem} aE (e, (l, r)) = let
fun lp (e, l, r) =
case getItem l & getItem r
- of NONE & NONE => (e, true)
- | NONE & SOME _ => (e, false)
- | SOME _ & NONE => (e, false)
+ of NONE & NONE => SOME e
+ | NONE & SOME _ => NONE
+ | SOME _ & NONE => NONE
| SOME (x, l) & SOME (y, r) =>
case aE (e, (x, y))
- of (e, true) => lp (e, l, r)
- | result => result
+ of SOME e => lp (e, l, r)
+ | NONE => NONE
in
lp (e, toSlice l, toSlice r)
end
- fun cyclic t = let
- val (to, from) = Univ.Emb.new ()
- fun lp (e, [], (l, r)) = t (to (l, r)::e, (l, r))
- | lp (e, u::us, (l, r)) =
- case from u
- of NONE => lp (e, us, (l, r))
- | SOME (a, b) =>
- if a = l andalso b = r orelse a = r andalso b = l then
- (e, true)
- else if (a = l) <> (b = r) orelse (a = r) <> (b = l) then
- (e, false)
- else
- lp (e, us, (l, r))
+ fun cyclic aT aE = let
+ val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
in
- fn (e, (l, r)) => lp (e, e, (l, r))
+ fn (e, (l, r)) => let
+ val lD = to l
+ val rD = to r
+ in
+ case HashMap.find e lD
+ of SOME rD' => if HashUniv.eq (rD, rD') then SOME e else NONE
+ | NONE =>
+ if isSome (HashMap.find e rD)
+ then NONE
+ else (HashMap.insert e (lD, rD)
+ ; HashMap.insert e (rD, lD)
+ ; aE (e, (l, r)))
+ end
end
- val exns : (e * Exn.t Sq.t -> (e * Bool.t) Option.t) Buffer.t = Buffer.new ()
+ val exns : (e * Exn.t Sq.t -> e Option.t Option.t) Buffer.t = Buffer.new ()
fun regExn aE (_, e2a) =
- (Buffer.push exns)
- (fn (e, (l, r)) =>
- case e2a l & e2a r
- of SOME l & SOME r => SOME (aE (e, (l, r)))
- | SOME _ & NONE => SOME (e, false)
- | NONE & SOME _ => SOME (e, false)
- | NONE & NONE => NONE)
+ (Buffer.push exns)
+ (fn (e, (l, r)) =>
+ case e2a l & e2a r
+ of SOME l & SOME r => SOME (aE (e, (l, r)))
+ | NONE & NONE => NONE
+ | _ => SOME NONE)
+ fun iso' getX bX =
+ case getX bX
+ of bE => fn (a2b, _) => fn (e, bp) => bE (e, Sq.map a2b bp)
+
structure Seq = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
open Seq.This
- fun seq t = Pair.snd o [] <\ getT t
+ fun seq t =
+ case getT t
+ of eq => fn xy => isSome (eq (HashMap.new {eq = HashUniv.eq,
+ hash = HashUniv.hash}, xy))
fun notSeq t = negate (seq t)
fun withSeq eq = mapT (const (lift eq))
- structure Layered = LayerCases
- (structure Outer = Arg and Result = Seq and Rep = Seq.Closed
+ structure Layered = LayerDepCases
+ (structure Outer = Arg and Result = Seq
- fun iso bE (a2b, _) (e, bp) = bE (e, Sq.map a2b bp)
- val isoProduct = iso
- val isoSum = iso
+ fun iso ? = iso' getT ?
+ fun isoProduct ? = iso' getP ?
+ fun isoSum ? = iso' getS ?
- fun op *` (aE, bE) (e, (lA & lB, rA & rB)) =
- case aE (e, (lA, rA))
- of (e, true) => bE (e, (lB, rB))
- | result => result
- val T = id
- fun R _ = id
- val tuple = id
- val record = id
+ fun op *` (aP, bP) = let
+ val aE = getP aP
+ val bE = getP bP
+ in
+ fn (e, (lA & lB, rA & rB)) =>
+ case aE (e, (lA, rA))
+ of SOME e => bE (e, (lB, rB))
+ | NONE => NONE
+ end
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
- fun op +` (aE, bE) (e, (l, r)) =
- case l & r
- of INL l & INL r => aE (e, (l, r))
- | INL _ & INR _ => (e, false)
- | INR _ & INL _ => (e, false)
- | INR l & INR r => bE (e, (l, r))
+ fun op +` (aS, bS) = let
+ val aE = getS aS
+ val bE = getS bS
+ in
+ fn (e, (INL l, INL r)) => aE (e, (l, r))
+ | (e, (INR l, INR r)) => bE (e, (l, r))
+ | _ => NONE
+ end
val unit = lift (fn ((), ()) => true)
fun C0 _ = unit
- fun C1 _ = id
- val data = id
+ fun C1 _ = getT
+ val data = getS
val Y = Tie.function
@@ -103,26 +118,28 @@
of NONE => GenericsUtil.failExnSq lr
| SOME r => r
fun regExn0 _ (e, p) = regExn unit (const e, p)
- fun regExn1 _ = regExn
+ fun regExn1 _ = regExn o getT
- fun array ? = cyclic (sequ {toSlice = ArraySlice.full,
- getItem = ArraySlice.getItem} ?)
- fun list ? = sequ {toSlice = id, getItem = List.getItem} ?
- fun vector ? = sequ {toSlice = VectorSlice.full,
- getItem = VectorSlice.getItem} ?
+ fun array aT =
+ cyclic (Arg.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 refc t = cyclic (iso t (!, undefined))
+ fun refc aT = cyclic (Arg.refc ignore aT) (iso aT (!, undefined))
val fixedInt = lift (op = : FixedInt.t BinPr.t)
val largeInt = lift (op = : LargeInt.t BinPr.t)
val largeWord = lift (op = : LargeWord.t BinPr.t)
- val largeReal = iso (lift op =) CastLargeReal.isoBits
+ val largeReal = iso' id (lift op =) CastLargeReal.isoBits
val bool = lift (op = : Bool.t BinPr.t)
val char = lift (op = : Char.t BinPr.t)
val int = lift (op = : Int.t BinPr.t)
- val real = iso (lift op =) CastReal.isoBits
+ val real = iso' id (lift op =) CastReal.isoBits
val string = lift (op = : String.t BinPr.t)
val word = lift (op = : Word.t BinPr.t)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-01 23:20:17 UTC (rev 5989)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-01 23:24:55 UTC (rev 5990)
@@ -140,8 +140,8 @@
signature REDUCE = REDUCE and REDUCE_CASES = REDUCE_CASES
functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = WithReduce (Arg)
-signature SEQ = SEQ and SEQ_CASES = SEQ_CASES
-functor WithSeq (Arg : OPEN_CASES) : SEQ_CASES = WithSeq (Arg)
+signature SEQ = SEQ and SEQ_CASES = SEQ_CASES and WITH_SEQ_DOM = WITH_SEQ_DOM
+functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = WithSeq (Arg)
signature SOME = SOME and SOME_CASES = SOME_CASES
and WITH_SOME_DOM = WITH_SOME_DOM
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-01 23:20:17 UTC (rev 5989)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-01 23:24:55 UTC (rev 5990)
@@ -34,3 +34,5 @@
include OPEN_CASES SEQ
sharing Rep = Seq
end
+
+signature WITH_SEQ_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-01 23:20:17 UTC (rev 5989)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-01 23:24:55 UTC (rev 5990)
@@ -8,7 +8,7 @@
structure Generic = struct
open Generic
local
- structure Open = WithSeq (Open)
+ structure Open = WithSeq (open Generic Open)
structure Extra = CloseWithExtra (Open)
in
open Open Extra
@@ -20,12 +20,12 @@
open Generic UnitTest
- fun chkEq t =
+ fun chkSeq t =
(chk o all t)
(fn x => let
val p = pickle t x
in
- that (eq t (x, unpickle t p))
+ that (seq t (x, unpickle t p))
end)
fun testSeq t x =
@@ -48,11 +48,11 @@
unitTests
(title "Generic.Pickle")
- (chkEq (vector (option (list real))))
- (chkEq (tuple2 (fixedInt, largeInt)))
- (chkEq (largeReal &` largeWord))
- (chkEq (tuple3 (word8, word32, word64)))
- (chkEq (bool &` char &` int &` real &` string &` word))
+ (chkSeq (vector (option (list real))))
+ (chkSeq (tuple2 (fixedInt, largeInt)))
+ (chkSeq (largeReal &` largeWord))
+ (chkSeq (tuple3 (word8, word32, word64)))
+ (chkSeq (bool &` char &` int &` real &` string &` word))
(title "Generic.Pickle.Cyclic")
More information about the MLton-commit
mailing list