[MLton-commit] r5994
Vesa Karvonen
vesak at mlton.org
Sun Sep 2 05:36:20 PDT 2007
As the environment is mutated, there is no need to return it. D'oh!
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-02 10:06:30 UTC (rev 5993)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-02 12:36:20 UTC (rev 5994)
@@ -7,30 +7,24 @@
functor WithOrd (Arg : WITH_ORD_DOM) : ORD_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix 4 <\
infix 0 &
(* SML/NJ workaround --> *)
type e = (HashUniv.t, HashUniv.t) HashMap.t
- datatype r = LT | EQ of e | GT
- type 'a t = e * 'a Sq.t -> r
+ type 'a t = e * 'a Sq.t -> Order.t
- fun lift (cmp : 'a Cmp.t) : 'a t =
- fn (e, xy) => case cmp xy
- of EQUAL => EQ e
- | LESS => LT
- | GREATER => GT
+ fun lift (cmp : 'a Cmp.t) : 'a t = cmp o #2
fun sequ {toSlice, getItem} aO (e, (l, r)) = let
fun lp (e, l, r) =
case getItem l & getItem r
- of NONE & NONE => EQ e
- | NONE & SOME _ => LT
- | SOME _ & NONE => GT
+ of NONE & NONE => EQUAL
+ | NONE & SOME _ => LESS
+ | SOME _ & NONE => GREATER
| SOME (x, l) & SOME (y, r) =>
case aO (e, (x, y))
- of EQ e => lp (e, l, r)
- | res => res
+ of EQUAL => lp (e, l, r)
+ | res => res
in
lp (e, toSlice l, toSlice r)
end
@@ -45,21 +39,21 @@
if case HashMap.find e lD
of SOME rD' => HashUniv.eq (rD, rD')
| NONE => false
- then EQ e
+ then EQUAL
else (HashMap.insert e (lD, rD)
; HashMap.insert e (rD, lD)
; aO (e, (l, r)))
end
end
- val exns : (e * Exn.t Sq.t -> r Option.t) Buffer.t = Buffer.new ()
+ val exns : (e * Exn.t Sq.t -> Order.t Option.t) Buffer.t = Buffer.new ()
fun regExn aO (_, e2a) =
(Buffer.push exns)
(fn (e, (l, r)) =>
case e2a l & e2a r
of SOME l & SOME r => SOME (aO (e, (l, r)))
- | SOME _ & NONE => SOME GT
- | NONE & SOME _ => SOME LT
+ | SOME _ & NONE => SOME GREATER
+ | NONE & SOME _ => SOME LESS
| NONE & NONE => NONE)
fun iso' getX bX (a2b, _) (e, bp) = getX bX (e, Sq.map a2b bp)
@@ -73,9 +67,7 @@
fun ord t = let
val ord = getT t
in
- fn xy =>
- case (ord (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy))
- of LT => LESS | EQ _ => EQUAL | GT => GREATER
+ fn xy => ord (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy)
end
fun withOrd cmp = mapT (const (lift cmp))
@@ -92,8 +84,8 @@
in
fn (e, (lA & lB, rA & rB)) =>
case aO (e, (lA, rA))
- of EQ e => bO (e, (lB, rB))
- | res => res
+ of EQUAL => bO (e, (lB, rB))
+ | res => res
end
val T = getT
fun R _ = getT
@@ -107,8 +99,8 @@
fn (e, (l, r)) =>
case l & r
of INL l & INL r => aO (e, (l, r))
- | INL _ & INR _ => LT
- | INR _ & INL _ => GT
+ | INL _ & INR _ => LESS
+ | INR _ & INL _ => GREATER
| INR l & INR r => bO (e, (l, r))
end
val unit = lift (fn ((), ()) => EQUAL)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-02 10:06:30 UTC (rev 5993)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-02 12:36:20 UTC (rev 5994)
@@ -7,26 +7,21 @@
functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix 4 <\
infix 0 &
(* SML/NJ workaround --> *)
type e = (HashUniv.t, HashUniv.t) HashMap.t
- type 'a t = e * 'a Sq.t -> e Option.t
+ type 'a t = e * 'a Sq.t -> Bool.t
- fun lift (eq : 'a BinPr.t) : 'a t =
- fn (e, xy) => if eq xy then SOME e else NONE
+ fun lift (eq : 'a BinPr.t) : 'a t = eq o #2
fun sequ {toSlice, getItem} aE (e, (l, r)) = let
fun lp (e, l, r) =
case getItem l & getItem r
- of NONE & NONE => SOME e
- | NONE & SOME _ => NONE
- | SOME _ & NONE => NONE
- | SOME (x, l) & SOME (y, r) =>
- case aE (e, (x, y))
- of SOME e => lp (e, l, r)
- | NONE => NONE
+ of NONE & NONE => true
+ | NONE & SOME _ => false
+ | SOME _ & NONE => false
+ | SOME (x, l) & SOME (y, r) => aE (e, (x, y)) andalso lp (e, l, r)
in
lp (e, toSlice l, toSlice r)
end
@@ -39,24 +34,22 @@
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)))
+ of SOME rD' => HashUniv.eq (rD, rD')
+ | NONE => isNone (HashMap.find e rD)
+ andalso (HashMap.insert e (lD, rD)
+ ; HashMap.insert e (rD, lD)
+ ; aE (e, (l, r)))
end
end
- val exns : (e * Exn.t Sq.t -> e Option.t Option.t) Buffer.t = Buffer.new ()
+ val exns : (e * Exn.t Sq.t -> Bool.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)))
| NONE & NONE => NONE
- | _ => SOME NONE)
+ | _ => SOME false)
fun iso' getX bX =
case getX bX
@@ -70,8 +63,8 @@
fun seq t =
case getT t
- of eq => fn xy => isSome (eq (HashMap.new {eq = HashUniv.eq,
- hash = HashUniv.hash}, xy))
+ of eq => fn xy => eq (HashMap.new {eq = HashUniv.eq,
+ hash = HashUniv.hash}, xy)
fun notSeq t = negate (seq t)
fun withSeq eq = mapT (const (lift eq))
@@ -87,9 +80,7 @@
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
+ aE (e, (lA, rA)) andalso bE (e, (lB, rB))
end
val T = getT
fun R _ = getT
@@ -102,7 +93,7 @@
in
fn (e, (INL l, INL r)) => aE (e, (l, r))
| (e, (INR l, INR r)) => bE (e, (l, r))
- | _ => NONE
+ | _ => false
end
val unit = lift (fn ((), ()) => true)
fun C0 _ = unit
More information about the MLton-commit
mailing list