[MLton-commit] r5902
Vesa Karvonen
vesak at mlton.org
Mon Aug 20 05:51:48 PDT 2007
Enhanced ord to support cyclic data structures.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-20 12:00:09 UTC (rev 5901)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-20 12:51:47 UTC (rev 5902)
@@ -7,33 +7,72 @@
functor WithOrd (Arg : OPEN_CASES) : ORD_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 * Order.t
+
+ fun lift (cmp : 'a Cmp.t) : 'a t = Pair.map (id, cmp)
+
+ fun seq {toSlice, getItem} aO (e, (l, r)) = let
+ fun lp (e, l, r) =
+ case (getItem l, getItem r)
+ of (NONE , NONE ) => (e, EQUAL)
+ | (NONE , SOME _ ) => (e, LESS)
+ | (SOME _ , NONE ) => (e, GREATER)
+ | (SOME (x, l), SOME (y, r)) =>
+ case aO (e, (x, y))
+ of (e, EQUAL) => lp (e, l, r)
+ | result => result
+ in
+ lp (e, toSlice l, toSlice r)
+ end
+
+ fun cyclic t = let
+ val (to, from) = Univ.Emb.new ()
+ in
+ fn (e, (l, r)) =>
+ if List.exists (fn u => case from u
+ of NONE => false
+ | SOME p => p = (l, r) orelse p = (r, l)) e
+ then (e, EQUAL)
+ else t (to (l, r)::e, (l, r))
+ end
+
structure Ord = LayerRep
(structure Outer = Arg.Rep
- structure Closed = MkClosedRep (Cmp))
+ structure Closed = MkClosedRep (type 'a t = 'a t))
open Ord.This
- val ord = getT
- fun withOrd cmp = mapT (const cmp)
+ fun ord t = Pair.snd o [] <\ getT t
+ fun withOrd cmp = mapT (const (lift cmp))
structure Layered = LayerCases
(structure Outer = Arg and Result = Ord and Rep = Ord.Closed
- fun iso b (a2b, _) = Cmp.map a2b b
+ fun iso bO (a2b, _) (e, bp) = bO (e, Sq.map a2b bp)
val isoProduct = iso
val isoSum = iso
- val op *` = Product.collate
+ fun op *` (aO, bO) (e, (lA & lB, rA & rB)) =
+ case aO (e, (lA, rA))
+ of (e, EQUAL) => bO (e, (lB, rB))
+ | result => result
val T = id
fun R _ = id
val tuple = id
val record = id
- val op +` = Sum.collate
- val unit = fn ((), ()) => EQUAL
+ fun op +` (aO, bO) (e, (l, r)) =
+ case (l, r)
+ of (INL l, INL r) => aO (e, (l, r))
+ | (INL _, INR _) => (e, LESS)
+ | (INR _, INL _) => (e, GREATER)
+ | (INR l, INR r) => bO (e, (l, r))
+ val unit = lift (fn ((), ()) => EQUAL)
fun C0 _ = unit
fun C1 _ = id
val data = id
@@ -42,46 +81,48 @@
fun op --> _ = failing "Ord.--> unsupported"
- val exns : (Exn.t Sq.t -> Order.t Option.t) Buffer.t = Buffer.new ()
- fun exn lr =
+ val exns : (e * Exn.t Sq.t -> (e * Order.t) Option.t) Buffer.t = Buffer.new ()
+ fun exn (e, lr) =
recur 0 (fn lp =>
fn i =>
if i = Buffer.length exns
then GenericsUtil.failExnSq lr
- else case Buffer.sub (exns, i) lr of
+ else case Buffer.sub (exns, i) (e, lr) of
SOME r => r
| NONE => lp (i+1))
- fun regExn cA (_, e2a) =
+ fun regExn aO (_, e2a) =
(Buffer.push exns)
- (fn (l, r) =>
+ (fn (e, (l, r)) =>
case e2a l & e2a r of
- SOME l & SOME r => SOME (cA (l, r))
- | SOME _ & NONE => SOME GREATER
- | NONE & SOME _ => SOME LESS
+ SOME l & SOME r => SOME (aO (e, (l, r)))
+ | SOME _ & NONE => SOME (e, GREATER)
+ | NONE & SOME _ => SOME (e, LESS)
| NONE & NONE => NONE)
- val array = Array.collate
- val list = List.collate
- val vector = Vector.collate
+ fun array ? = cyclic (seq {toSlice = ArraySlice.full,
+ getItem = ArraySlice.getItem} ?)
+ fun list ? = seq {toSlice = id, getItem = List.getItem} ?
+ fun vector ? = seq {toSlice = VectorSlice.full,
+ getItem = VectorSlice.getItem} ?
- fun refc t = Cmp.map ! t
+ fun refc t = cyclic (iso t (!, undefined))
- val fixedInt = FixedInt.compare
- val largeInt = LargeInt.compare
+ val fixedInt = lift FixedInt.compare
+ val largeInt = lift LargeInt.compare
- val largeWord = LargeWord.compare
- val largeReal = iso CastLargeReal.Bits.compare CastLargeReal.isoBits
+ val largeWord = lift LargeWord.compare
+ val largeReal = iso (lift CastLargeReal.Bits.compare) CastLargeReal.isoBits
- val bool = Bool.compare
- val char = Char.compare
- val int = Int.compare
- val real = iso CastReal.Bits.compare CastReal.isoBits
- val string = String.compare
- val word = Word.compare
+ val bool = lift Bool.compare
+ val char = lift Char.compare
+ val int = lift Int.compare
+ val real = iso (lift CastReal.Bits.compare) CastReal.isoBits
+ val string = lift String.compare
+ val word = lift Word.compare
- val word8 = Word8.compare
- val word32 = Word32.compare
- val word64 = Word64.compare)
+ val word8 = lift Word8.compare
+ val word32 = lift Word32.compare
+ val word64 = lift Word64.compare)
open Layered
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-08-20 12:00:09 UTC (rev 5901)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-08-20 12:51:47 UTC (rev 5902)
@@ -14,12 +14,15 @@
* invariant. If you truly need a structural equality relation for
* mutable types that ignores identity, see {ORD}.
*
+ * By default, comparison of data structures with cycles introduced
+ * through refs and arrays always terminates with a consistent result.
+ *
* By default, the comparison of reals is done bitwise. While this
- * matches the notion of equality provided for other types, this differs
- * from the notions of equality provided for reals by the Basis Library.
- * In particular, {~0.0} and {0.0} are considered unequal and {nan} is
- * considered equal to {nan}. This treatment is important for a number of
- * non-numerical applications such as serialization.
+ * matches the default notion of equality provided for other types, this
+ * differs from the notions of equality provided for reals by the Basis
+ * Library. In particular, {~0.0} and {0.0} are considered unequal and
+ * {nan} is considered equal to {nan}. This treatment is important for a
+ * number of non-numerical applications such as serialization.
*
* By default, user defined datatypes and exceptions are given a
* structural semantics of equality. Specifically, two datatype or
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-20 12:00:09 UTC (rev 5901)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-20 12:51:47 UTC (rev 5902)
@@ -18,10 +18,14 @@
* This means that the ordering of mutable objects is not invariant with
* respect to mutation.
*
+ * By default, comparison of data structures with cycles introduced
+ * through references and arrays always terminates with a consistent
+ * result.
+ *
* By default, the comparison of reals is done bitwise. While this
- * matches the notion of ordering for other types, this differs from the
- * notions of ordering provided for reals by the Basis library. In
- * particular, {~0.0} and {0.0} are considered unequal and {nan} is
+ * matches the default notion of ordering for other types, this differs
+ * from the notions of ordering provided for reals by the Basis library.
+ * In particular, {~0.0} and {0.0} are considered unequal and {nan} is
* considered equal to {nan}. This treatment is important for a number of
* non-numerical applications such as serialization.
*
More information about the MLton-commit
mailing list