[MLton-commit] r5905
Vesa Karvonen
vesak at mlton.org
Mon Aug 20 15:49:30 PDT 2007
Added a structural equality predicate for testing pickling.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-20 16:18:57 UTC (rev 5904)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-20 22:49:29 UTC (rev 5905)
@@ -29,6 +29,7 @@
../../../public/value/pickle.sig
../../../public/value/pretty.sig
../../../public/value/reduce.sig
+ ../../../public/value/seq.sig
../../../public/value/some.sig
../../../public/value/transform.sig
../../../public/value/type-info.sig
@@ -48,6 +49,7 @@
../../value/pickle.sml
../../value/pretty.sml
../../value/reduce.sml
+ ../../value/seq.sml
../../value/some.sml
../../value/transform.sml
../../value/type-info.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-08-20 16:18:57 UTC (rev 5904)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-08-20 22:49:29 UTC (rev 5905)
@@ -0,0 +1,135 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithSeq (Arg : OPEN_CASES) : 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
+
+ fun lift (eq : 'a BinPr.t) : 'a t = Pair.map (id, eq)
+
+ 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)
+ | SOME (x, l) & SOME (y, r) =>
+ case aE (e, (x, y))
+ of (e, true) => lp (e, l, r)
+ | result => result
+ 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))
+ in
+ fn (e, (l, r)) => lp (e, e, (l, r))
+ end
+
+ 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 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
+
+ fun iso bE (a2b, _) (e, bp) = bE (e, Sq.map a2b bp)
+ val isoProduct = iso
+ val isoSum = iso
+
+ 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 +` (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))
+ val unit = lift (fn ((), ()) => true)
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id
+
+ val Y = Tie.function
+
+ fun op --> _ = failing "Seq.--> unsupported"
+
+ val exns : (e * Exn.t Sq.t -> (e * Bool.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) (e, lr)
+ of SOME r => r
+ | NONE => lp (i+1))
+ 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)
+
+ 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 refc t = cyclic (iso t (!, 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 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 string = lift (op = : String.t BinPr.t)
+ val word = lift (op = : Word.t BinPr.t)
+
+ val word8 = lift (op = : Word8.t BinPr.t)
+ val word32 = lift (op = : Word32.t BinPr.t)
+ val word64 = lift (op = : Word64.t BinPr.t))
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-20 16:18:57 UTC (rev 5904)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-20 22:49:29 UTC (rev 5905)
@@ -102,6 +102,9 @@
public/value/reduce.sig
detail/value/reduce.sml
+ public/value/seq.sig
+ detail/value/seq.sml
+
public/value/transform.sig
detail/value/transform.sml
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-20 16:18:57 UTC (rev 5904)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-20 22:49:29 UTC (rev 5905)
@@ -143,6 +143,10 @@
signature REDUCE_CASES = REDUCE_CASES
functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = WithReduce (Arg)
+signature SEQ = SEQ
+signature SEQ_CASES = SEQ_CASES
+functor WithSeq (Arg : OPEN_CASES) : SEQ_CASES = WithSeq (Arg)
+
signature SOME = SOME
signature SOME_CASES = SOME_CASES
signature WITH_SOME_DOM = WITH_SOME_DOM
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-08-20 16:18:57 UTC (rev 5904)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-08-20 22:49:29 UTC (rev 5905)
@@ -0,0 +1,36 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a structural equality predicate.
+ *
+ * By default, the semantics of the predicate corresponds to the equality
+ * relation that can be achieved through pickling and unpickling. While
+ * the identities of mutable objects need not be equal, it is required that
+ * there is a one-to-one correspondence between the identities of the
+ * mutable objects of the compared values.
+ *
+ * This equality predicate is unlikely to be useful in most applications.
+ * However, this is useful for testing the correctness of pickling and
+ * other similar generics.
+ *)
+signature SEQ = sig
+ structure Seq : OPEN_REP
+
+ val seq : ('a, 'x) Seq.t -> 'a BinPr.t
+ (** Extracts the equality predicate. *)
+
+ val notSeq : ('a, 'x) Seq.t -> 'a BinPr.t
+ (** {notSeq t = not o seq t} *)
+
+ val withSeq : 'a BinPr.t -> ('a, 'x) Seq.t UnOp.t
+ (** Functionally updates the equality predicate. *)
+end
+
+signature SEQ_CASES = sig
+ include OPEN_CASES SEQ
+ sharing Rep = Seq
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list