[MLton-commit] r5926
Vesa Karvonen
vesak at mlton.org
Wed Aug 22 06:26:05 PDT 2007
Changed from regExn with an incomplete sum to regExn0 and regExn1 with a
complete type. The original idea of the regExn design to avoid having to
duplicate the nullary/unary constructor distinction by reusing the
incomplete sum rep just doesn't work nicely. In particular, many generics
really need each exception constructor to be registered separately and
using an incomplete sum rep just doesn't enforce it statically. Wish I
had tried to implement more support for exceptions earlier. :-( Well,
that is what you get for delaying tedious but "straightforward" work!
Added some minimal unit tests for the generics. More is needed.
Also committed some "semantic" enhancements to the pickling generic. The
current implementation is NOT particularly optimized at the low-level.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/Check.bgb
A mltonlib/trunk/com/ssh/generic/unstable/Test.bgb
A mltonlib/trunk/com/ssh/generic/unstable/Test.sh
U mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.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/some.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
A mltonlib/trunk/com/ssh/generic/unstable/test/
A mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml
A mltonlib/trunk/com/ssh/generic/unstable/test.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/Check.bgb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Check.bgb 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/Check.bgb 2007-08-22 13:25:59 UTC (rev 5926)
@@ -4,5 +4,5 @@
;; See the LICENSE file or http://mlton.org/License for details.
(bg-build
- :name "Generics"
+ :name "Generics Check"
:shell "./Check.sh")
Added: mltonlib/trunk/com/ssh/generic/unstable/Test.bgb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.bgb 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test.bgb 2007-08-22 13:25:59 UTC (rev 5926)
@@ -0,0 +1,8 @@
+;; 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.
+
+(bg-build
+ :name "Generics Test"
+ :shell "./Test.sh")
Added: mltonlib/trunk/com/ssh/generic/unstable/Test.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-08-22 13:25:59 UTC (rev 5926)
@@ -0,0 +1,25 @@
+#!/bin/bash
+
+# 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.
+
+set -e
+set -x
+
+mkdir -p generated
+
+echo "SML_COMPILER mlton
+MLTON_LIB $(cd ../../../.. && pwd)" > generated/mlb-path-map
+
+time \
+mlton -mlb-path-map generated/mlb-path-map \
+ -prefer-abs-paths true \
+ -show-def-use generated/test.du \
+ -output generated/test \
+ -const 'Exn.keepHistory true' \
+ test.mlb
+
+time \
+generated/test
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/Test.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-08-22 13:25:59 UTC (rev 5926)
@@ -45,7 +45,8 @@
fun Y ? = Arg.Y (Tie.id ()) ?
fun op --> ? = Arg.--> ignore ?
val exn = Arg.exn ()
- fun regExn ? = Arg.regExn (const ignore) ?
+ fun regExn0 ? = Arg.regExn0 (const ignore) ?
+ fun regExn1 ? = Arg.regExn1 (const (const ignore)) ?
fun array ? = Arg.array ignore ?
fun refc ? = Arg.refc ignore ?
fun vector ? = Arg.vector ignore ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-08-22 13:25:59 UTC (rev 5926)
@@ -77,8 +77,11 @@
fun c1 outer this cx2y c a =
outer (fn c => fn x => Inner.mkS (this c a, cx2y c (Inner.getT x))) c a
fun y outer x y = outer (Inner.mkY (x, y))
- fun re outer this ex a =
- outer (fn x => fn e => (this a e : Unit.t ; ex (Inner.getS x) e : Unit.t)) a
+ fun re0 outer this ex =
+ outer (fn c => fn e => (this c e : Unit.t ; ex c e : Unit.t))
+ fun re1 outer this ex c a =
+ outer (fn c => fn x => fn e =>
+ (this c a e : Unit.t ; ex c (Inner.getT x) e : Unit.t)) c a
fun iso ? = m Inner.mkT Inner.getT Outer.iso Arg.iso ?
fun isoProduct ? = m Inner.mkP Inner.getP Outer.isoProduct Arg.isoProduct ?
@@ -96,7 +99,8 @@
fun Y ? = y Outer.Y Arg.Y ?
fun op --> ? = op2 Inner.mkT Inner.getT Inner.getT Outer.--> Arg.--> ?
fun exn ? = op0t Outer.exn Arg.exn ?
- fun regExn ? = re Outer.regExn Arg.regExn ?
+ fun regExn0 ? = re0 Outer.regExn0 Arg.regExn0 ?
+ fun regExn1 ? = re1 Outer.regExn1 Arg.regExn1 ?
fun array ? = op1t Outer.array Arg.array ?
fun refc ? = op1t Outer.refc Arg.refc ?
fun vector ? = op1t Outer.vector Arg.vector ?
@@ -140,4 +144,4 @@
fun record a = Arg.record (getP a)
fun C1 c a = Arg.C1 c (getT a)
fun data a = Arg.data (getS a)
- fun regExn a e = Arg.regExn (getS a) e)
+ fun regExn1 c = Arg.regExn1 c o getT)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -39,7 +39,8 @@
val Y = id
val op --> = id
val exn = id
- val regExn = id
+ val regExn0 = id
+ val regExn1 = id
val array = id
val refc = id
val vector = id
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -90,8 +90,9 @@
fun op --> (a, b) = op -->` (getT a, getT b)
val exn = IN {gen = G.return Empty,
- cog = failing "Arbitrary.exn unsupported"}
- fun regExn _ _ = ()
+ cog = failing "Arbitrary.exn not yet implemented"}
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
fun list' (IN {gen = xGen, cog = xCog}) = let
val xsGen = G.sized (0 <\ G.intInRange) >>= G.list xGen
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -88,7 +88,8 @@
fun op --> _ = base
val exn = INT {exn = true, pure = true, recs = []}
- fun regExn _ _ = ()
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
val array = mutable
val refc = mutable
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -51,9 +51,12 @@
val op --> = ignore
- val exnCons : String.t List.t Ref.t = ref []
- fun regExn cs _ = exnCons := addN "exception constructor" (!exnCons, cs)
+ val exns : String.t List.t Ref.t = ref []
val exn = ()
+ fun regExn c =
+ exns := add1 "exception constructor" (Con.toString c, !exns)
+ fun regExn0 c _ = regExn c
+ fun regExn1 c _ _ = regExn c
val list = ignore
val vector = ignore
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -75,7 +75,8 @@
fun op --> is = (ARROW, fn ARROW ? => ? | _ => raise Dyn) <--> Fn.iso is
val exn = (EXN, fn EXN ? => ? | _ => raise Dyn)
- fun regExn _ _ = ()
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
fun list i = (LIST, fn LIST ? => ? | _ => raise Dyn) <--> List.iso i
fun vector i = (VECTOR, fn VECTOR ? => ? | _ => raise Dyn) <--> Vector.iso i
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -64,6 +64,8 @@
of NONE & NONE => exnHandler (l, r)
| SOME l & SOME r => t (l, r)
| _ => false) exnHandler
+ fun regExn0 _ = regExn unit
+ fun regExn1 _ = regExn
fun exn ? = !exnHandler ?
val list = ListPair.allEq
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -116,7 +116,8 @@
val string = hashSeq String.length String.sub char
val exn = string o Exn.message (* XXX Imprecise *)
- fun regExn _ _ = ()
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
val bool = prim (fn true => 0wx2DA745 | false => 0wx3C24A62)
val real =
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -94,6 +94,8 @@
| SOME _ & NONE => SOME (e, GREATER)
| NONE & SOME _ => SOME (e, LESS)
| NONE & NONE => NONE)
+ fun regExn0 _ = regExn unit
+ fun regExn1 _ = regExn
fun array ? = cyclic (seq {toSlice = ArraySlice.full,
getItem = ArraySlice.getItem} ?)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -15,7 +15,7 @@
end = struct
open HashTable
type ('a, 'b) t = ('a, 'b) hash_table
- fun new {eq, hash} = mkTable (hash, eq) (100, Subscript)
+ fun new {eq, hash} = mkTable (hash, eq) (127, Subscript)
end
(************************************************************************)
@@ -46,85 +46,91 @@
(************************************************************************)
+functor MkIOSMonad (State : T) : sig
+ type 'a t
+ include MONAD where type 'a monad = 'a t
+ val Y : 'a t Tie.t
+end = struct
+ structure Monad =
+ MkMonad (type 'a monad = ('a, State.t) IOSMonad.t open IOSMonad)
+ open Monad IOSMonad
+ type 'a t = 'a monad
+ val Y = Tie.function
+end
+
+(************************************************************************)
+
functor MkIstream (State : T) :> sig
type 'a t
+ include MONAD where type 'a monad = 'a t
val Y : 'a t Tie.t
- val run : State.t -> 'a t -> (Char.t, 'b) Reader.t -> ('a, 'b) Reader.t
+ val run : State.t -> 'a t -> (Char.t, 's) IOSMonad.t -> ('a, 's) IOSMonad.t
val read : Char.t t
structure State : T where type t = State.t
val getState : State.t t
val setState : State.t -> Unit.t t
- include MONAD where type 'a monad = 'a t
end = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
- open Reader
- datatype t = T of {st : Univ.t, rd : (Char.t, Univ.t) Reader.t, us : State.t}
- type 'a t = ('a, t) Reader.t
- val Y = Tie.function
- fun run us f cr = let
+ datatype t =
+ T of {st : Univ.t, rd : (Char.t, Univ.t) IOSMonad.t, us : State.t}
+ structure Monad = MkIOSMonad (type t = t)
+ open IOSMonad Monad
+ fun run us f cM = let
val (to, from) = Univ.Iso.new ()
in
- mapState (fn s => T {st = to s, rd = mapState (from, to) cr, us = us},
- fn T r => from (#st r))
- f
+ mapState (fn s => T {st = to s, rd = mapState (from, to) cM, us = us},
+ fn T r => from (#st r)) f
end
fun read (T {st, rd, us}) =
- Option.map (Pair.map (id, fn st => T {st=st, rd=rd, us=us})) (rd st)
+ Pair.map (id, fn st => T {st=st, rd=rd, us=us}) (rd st)
structure State = State
- fun getState (s as T {us, ...}) = SOME (us, s)
- fun setState us (T {st, rd, ...}) = SOME ((), T {st=st, rd=rd, us=us})
- structure Monad =
- MkMonad (type 'a monad = 'a t
- fun return a s = SOME (a, s)
- fun op >>= (rA, a2rB) s = case rA s
- of NONE => NONE
- | SOME (a, s) => a2rB a s)
- open Monad
+ fun getState (s as T {us, ...}) = (us, s)
+ fun setState us (T {st, rd, ...}) = ((), T {st=st, rd=rd, us=us})
end
(************************************************************************)
functor MkOstream (State : T) :> sig
type 'a t
+ include MONAD where type 'a monad = 'a t
val Y : 'a t Tie.t
- val run : State.t -> ('a -> Unit.t t) -> (Char.t, 'b) Writer.t -> ('a, 'b) Writer.t
+ val run : State.t -> ('a -> Unit.t t) -> (Char.t -> (Unit.t, 's) IOSMonad.t)
+ -> ('a -> (Unit.t, 's) IOSMonad.t)
val write : Char.t -> Unit.t t
structure State : T where type t = State.t
val getState : State.t t
val setState : State.t -> Unit.t t
- include MONAD where type 'a monad = 'a t
end = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
- open Writer
- datatype t = T of {st : Univ.t, wr : (Char.t, Univ.t) Writer.t, us : State.t}
- type 'a t = t -> 'a * t
- val Y = Tie.function
- fun run us f cw (a, s) = let
+ datatype t =
+ T of {st : Univ.t,
+ wr : Char.t -> (Unit.t, Univ.t) IOSMonad.t,
+ us : State.t}
+ structure Monad = MkIOSMonad (type t = t)
+ open IOSMonad Monad
+ fun run us f c2uM = let
val (to, from) = Univ.Iso.new ()
in
- case f a (T {st = to s, wr = mapState (from, to) cw, us = us})
- of ((), T r) => from (#st r)
+ mapState (fn s => T {st = to s, wr = mapState (from, to) o c2uM, us = us},
+ fn T r => from (#st r)) o f
end
- fun write c (T r) = ((), T {st = #wr r (c, #st r), wr = #wr r, us = #us r})
+ fun write c (T r) =
+ Pair.map (id, fn st => T {st = st, wr = #wr r, us = #us r})
+ (#wr r c (#st r))
structure State = State
fun getState (s as T {us, ...}) = (us, s)
fun setState us (T {st, wr, ...}) = ((), T {st=st, wr=wr, us=us})
- structure Monad =
- MkMonad (type 'a monad = 'a t
- fun return x s = (x, s)
- fun op >>= (mA, a2mB) s = uncurry a2mB (mA s))
- open Monad
end
(************************************************************************)
functor WordWithOps (Arg : WORD) = struct
open Arg
- val ops = {wordSize = wordSize, orb = op orb, << = op <<, >> = op >>,
+ val ops = {wordSize = wordSize, orb = op orb, << = op <<, ~>> = op ~>>,
isoWord8 = isoWord8}
end
@@ -184,62 +190,141 @@
val swap = Iso.swap
val word8Ichar = (Byte.byteToChar, Byte.charToByte)
- fun bits {wordSize=n, orb, <<, >>, isoWord8} (toBits, fromBits) = let
- val (toChar, fromChar) = word8Ichar <--> isoWord8
- fun alts ` op + =
- if n <= 8 then `0
- else if n <= 16 then `0 + `8
- else if n <= 32 then `0 + `8 + `16 + `24
- else if n <= 64 then `0 + `8 + `16 + `24 + `32 + `40 + `48 + `56
+ fun iso' get bT (a2b, b2a) = let
+ val {rd, wr, sz} = get bT
+ in
+ {rd = I.map b2a rd, wr = wr o a2b, sz = sz}
+ end
+
+ val char = {rd = I.read, wr = O.write, sz = SOME 1}
+ val word8 = iso' id char word8Ichar
+ val intAs8 = iso' id char (swap Char.isoInt)
+
+ (* Pickles a positive int using a variable length encoding. *)
+ val size =
+ {rd = let
+ open I
+ fun lp (v, m) =
+ #rd word8 >>= (fn b =>
+ if b < 0wx80
+ then return (v + Word8.toInt b * m)
+ else lp (v + Word8.toInt (b - 0wx80) * m, m * 0x80))
+ in
+ lp (0, 1)
+ end,
+ wr = let
+ open O
+ fun lp i =
+ if i < 0x80
+ then #wr word8 (Word8.fromInt i)
+ else #wr word8 (Word8.andb (0wx7F, Word8.fromInt i)) >>= (fn () =>
+ lp (Int.quot (i, 0x80)))
+ in
+ fn i => if i < 0 then fail "Negative size" else return i >>= lp
+ end,
+ sz = SOME 2}
+
+ (* Encodes either 8, 16, 32, or 64 bits of data and an optional size. *)
+ fun bits sized {wordSize=n, orb, <<, ~>>, isoWord8 = (toWord8, fromWord8)}
+ (toBits, fromBits) = let
+ fun alts ` op o =
+ if n <= 8 then `0w0
+ else if n <= 16 then `0w0o`0w8
+ else if n <= 32 then `0w0o`0w8o`0w16o`0w24
+ else if n <= 64 then `0w0o`0w8o`0w16o`0w24o`0w32o`0w40o`0w48o`0w56
else fail "Too many bits"
in
{rd = let
open I
- fun ` n = map (fn c => fromChar c << Word.fromInt n) read
- fun l + r = map op orb (l >>* r)
+ fun ` n = map (fn b => fromWord8 b << n) (#rd word8)
+ fun l o r = map op orb (l >>* r)
+ val rdBits = map fromBits (alts ` op o)
in
- map fromBits (alts ` op +)
+ if sized
+ then #rd size >>= (fn m =>
+ if m <> n
+ then fail "Wrong number of bits in pickle"
+ else rdBits)
+ else rdBits
end,
wr = fn v => let
- val bits = toBits v
- in
- alts (fn n => O.write (toChar (bits >> Word.fromInt n))) O.>>
- end,
- sz = SOME ((n + 7) div 8)}
+ open O
+ val bits = toBits v
+ val wrBits = alts (fn n => #wr word8 (toWord8 (bits ~>> n))) op >>
+ in
+ if sized then #wr size n >> wrBits else wrBits
+ end,
+ sz = SOME ((n + 7) div 8 + Bool.toInt sized)}
end
- fun iso' get bT (a2b, b2a) = let
- val {rd, wr, sz} = get bT
+ val intAs16 = let
+ open Word
in
- {rd = I.map b2a rd, wr = wr o a2b, sz = sz}
+ bits false
+ {wordSize = 16, orb = op orb, << = op <<, ~>> = op ~>>,
+ isoWord8 = isoWord8}
+ (swap Word.isoInt)
end
- val char = {rd = I.read, wr = O.write, sz = SOME 1}
- val int = bits Word.ops (swap Word.isoIntX)
- val bool = iso' id char (swap Char.isoInt <--> Bool.isoInt)
+ (* Encodes fixed size int as a size followed by little endian bytes. *)
+ fun mkFixedInt (fromLargeWordX, toLargeWord) =
+ {rd = let
+ open I
+ fun lp (1, s, w) =
+ #rd word8 >>= (fn b =>
+ return (fromLargeWordX (LargeWord.<< (LargeWord.fromWord8X b, s)
+ + w)))
+ | lp (n, s, w) =
+ #rd word8 >>= (fn b =>
+ lp (n-1, s+0w8, LargeWord.<< (LargeWord.fromWord8 b, s) + w))
+ in
+ #rd size >>= (fn 0 => return (fromLargeWordX 0w0)
+ | n => lp (n, 0w0, 0w0))
+ end,
+ wr = let
+ open O
+ fun lp (n, w, wr) = let
+ val n = n+1
+ val b = LargeWord.toWord8 w
+ val wr = wr >> #wr word8 b
+ in
+ if LargeWord.fromWord8X b = w
+ then #wr size n >> wr
+ else lp (n, LargeWord.~>> (w, 0w8), wr)
+ end
+ in
+ fn i => case toLargeWord i
+ of 0w0 => #wr size 0
+ | w => lp (0, w, return ())
+ end,
+ sz = SOME 4}
+ val () = if LargeWord.wordSize < valOf FixedInt.precision
+ then fail "LargeWord can't hold a FixedInt"
+ else ()
+ val fixedInt = mkFixedInt LargeWord.isoFixedIntX
+
fun cyclic {readProxy, readBody, writeWhole, self} = let
val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq self, hash = Arg.hash self}
open I
in
- {rd = #rd bool >>& getState >>= (fn def & mp =>
- if def
+ {rd = #rd size >>& getState >>= (fn i & mp =>
+ if 0 = i
then readProxy >>= (fn proxy =>
(HashMap.insert mp (HashMap.numItems mp, toDyn proxy)
; readBody proxy >> return proxy))
- else #rd int >>= (fn i =>
- case HashMap.find mp i
+ else case HashMap.find mp (i-1)
of NONE => fail "Corrupted pickle"
- | SOME d => return (fromDyn d))),
+ | SOME d => return (fromDyn d)),
wr = fn v => let
val d = toDyn v
open O
in
getState >>= (fn mp =>
case HashMap.find mp d
- of SOME i => #wr bool false >> #wr int i
+ of SOME i => #wr size (i+1)
| NONE => (HashMap.insert mp (d, HashMap.numItems mp)
- ; #wr bool true >> writeWhole v))
+ ; #wr size 0 >> writeWhole v))
end,
sz = NONE}
end
@@ -248,23 +333,22 @@
val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq t, hash = Arg.hash t}
open I
in
- {rd = #rd bool >>& getState >>= (fn def & mp =>
- if def
+ {rd = #rd size >>& getState >>= (fn i & mp =>
+ if 0 = i
then rdE >>= (fn v =>
(HashMap.insert mp (HashMap.numItems mp, toDyn v)
; return v))
- else #rd int >>= (fn i =>
- case HashMap.find mp i
+ else case HashMap.find mp (i-1)
of NONE => fail "Corrupted pickle"
- | SOME d => return (fromDyn d))),
+ | SOME d => return (fromDyn d)),
wr = fn v => let
val d = toDyn v
open O
in
getState >>= (fn mp =>
case HashMap.find mp d
- of SOME i => #wr bool false >> #wr int i
- | NONE => #wr bool true >> wrE v >>= (fn () =>
+ of SOME i => #wr size (i+1)
+ | NONE => #wr size 0 >> wrE v >>= (fn () =>
(HashMap.insert mp (d, HashMap.numItems mp)
; return ())))
end,
@@ -282,13 +366,10 @@
fun seq {length, toSlice, getItem, fromList} {rd = rdE, wr = wrE, sz = _} =
{rd = let
open I
+ fun lp (0, es) = return (fromList (rev es))
+ | lp (n, es) = rdE >>= (fn e => lp (n-1, e::es))
in
- #rd int >>= (fn n => let
- fun lp (0, es) = return (fromList (rev es))
- | lp (n, es) = rdE >>= (fn e => lp (n-1, e::es))
- in
- if n < 0 then fail "Corrupted pickle" else lp (n, [])
- end)
+ #rd size >>= lp /> []
end,
wr = let
open O
@@ -297,14 +378,89 @@
of NONE => return ()
| SOME (e, sl) => wrE e >>= (fn () => lp sl)
in
- fn seq => #wr int (length seq) >>= (fn () => lp (toSlice seq))
+ fn seq => #wr size (length seq) >>= (fn () =>
+ lp (toSlice seq))
end,
sz = NONE : OptInt.t}
- val string' = seq {length = String.length, toSlice = Substring.full,
- getItem = Substring.getc, fromList = String.fromList}
- char
+ val string =
+ share (Arg.string ())
+ (seq {length = String.length, toSlice = Substring.full,
+ getItem = Substring.getc, fromList = String.fromList}
+ char)
+ val c2b = Byte.charToByte
+ val b2c = Byte.byteToChar
+ fun h2n c =
+ c2b c - (if Char.inRange (#"0", #"9") c then c2b #"0"
+ else if Char.inRange (#"a", #"f") c then c2b #"a" - 0w10
+ else if Char.inRange (#"A", #"F") c then c2b #"A" - 0w10
+ else fail "Bug in fmt")
+ fun n2h n = b2c (n + (if n < 0w10 then c2b #"0" else c2b #"a" - 0w10))
+ local
+ fun makePos8 i = let
+ val n = Word.fromInt (IntInf.log2 (~i))
+ in
+ i + IntInf.<< (1, Word.andb (Word.~ 0w8, n + 0w8))
+ end
+ in
+ fun i2h i =
+ if i < 0
+ then let
+ val s = IntInf.fmt StringCvt.HEX (makePos8 i)
+ in
+ if 0w8 <= h2n (String.sub (s, 0)) then s else "ff"^s
+ end
+ else let
+ val s = IntInf.fmt StringCvt.HEX i
+ val (t, f) =
+ if Int.isOdd (String.size s)
+ then ("0", "0")
+ else ("00", "")
+ in
+ (if 0w8 <= h2n (String.sub (s, 0)) then t else f) ^ s
+ end
+ end
+ fun h2i h = let
+ val i = valOf (StringCvt.scanString (IntInf.scan StringCvt.HEX) h)
+ in
+ if 0w8 <= h2n (String.sub (h, 0))
+ then i - IntInf.<< (1, Word.fromInt (IntInf.log2 i + 1))
+ else i
+ end
+
+ val intInf =
+ {wr = let
+ open O
+ fun lp (_, 0) = return ()
+ | lp (s, i) = case i - 1 of i => pl (s, i, h2n (String.sub (s, i)))
+ and pl (_, 0, b) = #wr word8 b
+ | pl (s, i, b) = let
+ val i = i - 1
+ in
+ #wr word8 (b + Word8.<< (h2n (String.sub (s, i)), 0w4)) >>=
+ (fn () => lp (s, i))
+ end
+ in
+ fn 0 => #wr size 0
+ | i => let
+ val s = i2h i
+ val n = String.length s
+ in
+ #wr size (Int.quot (n, 2)) >>= (fn () => lp (s, n))
+ end
+ end,
+ rd = let
+ open I
+ fun lp (cs, 0) = return (h2i (implode cs))
+ | lp (cs, n) =
+ #rd word8 >>= (fn b =>
+ lp (n2h (Word8.>> (b, 0w4))::n2h (Word8.andb (b, 0wxF))::cs, n-1))
+ in
+ #rd size >>= (fn 0 => return 0 | n => lp ([], n))
+ end,
+ sz = NONE : OptInt.t}
+
structure Pickle = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
@@ -313,11 +469,20 @@
open Pickle.This
- fun pickle t =
+ fun pickler t =
O.run (HashMap.new {eq = Dyn.eq, hash = Dyn.hash}) (#wr (getT t))
- fun unpickle t =
+ fun unpickler t =
I.run (HashMap.new {eq = op =, hash = Word.fromInt}) (#rd (getT t))
+ fun pickle t = let
+ val pA = pickler t (IOSMonad.fromPutter (uncurry Buffer.push))
+ in
+ fn a => Buffer.toString o Pair.snd o pA a |< Buffer.new ()
+ end
+ fun unpickle t =
+ Pair.fst o unpickler t (IOSMonad.fromReader Substring.getc) o
+ Substring.full
+
structure Layered = LayerDepCases
(structure Outer = Arg and Result = Pickle
@@ -379,19 +544,19 @@
end
fun data s = let
val n = Arg.numAlts s
- val (rdTag, wrTag, szTag) =
- if n <= Char.maxOrd + 1
- then (I.map ord I.read, O.write o chr, SOME 1)
- else (#rd int, #wr int, #sz int)
+ val tag =
+ if n < 256 then intAs8
+ else if n < 65536 then intAs16
+ else fail "Too many tags"
val {rd, wr, sz} = getS s 0
open I
in
- {rd = rdTag >>= (fn i =>
+ {rd = #rd tag >>= (fn i =>
if n <= i
then fail "Corrupted pickle"
else rd i),
- wr = wr wrTag,
- sz = let open OptInt in sz div SOME n + szTag end}
+ wr = wr (#wr tag),
+ sz = let open OptInt in sz div SOME n + #sz tag end}
end
fun Y ? = let open Tie in iso (I.Y *` function *` id NONE) end
@@ -412,7 +577,7 @@
fun array t = let
val {rd, wr, sz = _} = getT t
in
- mutable {readProxy = I.map (Array.array /> Arg.some t) (#rd int),
+ mutable {readProxy = I.map (Array.array /> Arg.some t) (#rd size),
readBody = fn a => let
open I
fun lp i = if i = Array.length a
@@ -429,7 +594,7 @@
then return ()
else wr (Array.sub (a, i)) >>= (fn () => lp (i+1))
in
- #wr int (Array.length a) >>= (fn () => lp 0)
+ #wr size (Array.length a) >>= (fn () => lp 0)
end,
self = Arg.array ignore t}
end
@@ -445,73 +610,53 @@
getItem = VectorSlice.getItem,
fromList = Vector.fromList} (getT t))
- val exn : Exn.t t = fake "Pickle.exn unimplemented"
- fun regExn _ _ = ()
-
- val fixedInt = bits LargeWord.ops (swap LargeWord.isoFixedIntX)
- val largeInt = let
- fun to i = let
- val buffer = Buffer.new ()
- fun hexToInt c =
- ord c - (if Char.inRange (#"0", #"9") c then ord #"0"
- else if Char.inRange (#"a", #"f") c then ord #"a" - 10
- else if Char.inRange (#"A", #"F") c then ord #"A" - 10
- else fail "Bug in LargeInt.fmt")
- fun pack s =
- if Int.isOdd (Substring.size s) then pl (0, s) else lp s
- and lp s =
- case Substring.getc s
- of NONE => ()
- | SOME (c, s) => pl (hexToInt c, s)
- and pl (i, s) =
- case Substring.getc s
- of NONE => fail "Bug"
- | SOME (c, s) =>
- (Buffer.push buffer (chr (hexToInt c * 16 + i)) ; lp s)
- in
- Buffer.push buffer (if i < 0 then #"\001" else #"\000")
- ; pack (Substring.full (LargeInt.fmt StringCvt.HEX (abs i)))
- ; Buffer.toString buffer
- end
- fun from s = let
- val buffer = Buffer.new ()
- fun intToHex i = chr (i + (if i<10 then ord #"0" else ord #"A"-10))
- fun lp s =
- case Substring.getc s
- of NONE => ()
- | SOME (c, s) =>
- (Buffer.push buffer (intToHex (Int.rem (ord c, 16)))
- ; Buffer.push buffer (intToHex (Int.quot (ord c, 16)))
- ; lp s)
- in
- if size s < 2 then fail "Corrupted pickle" else ()
- ; case String.sub (s, 0)
- of #"\000" => ()
- | #"\001" => Buffer.push buffer #"~"
- | _ => fail "Corrupted pickle"
- ; lp (Substring.triml 1 (Substring.full s))
- ; case LargeInt.scan StringCvt.HEX Substring.getc
- (Substring.full (Buffer.toString buffer))
- of NONE => fail "Corrupted pickle"
- | SOME (i, _) => i
- end
+ val exns : {rd : String.t -> Exn.t I.t Option.t,
+ wr : Exn.t -> Unit.t O.t Option.t} Buffer.t =
+ Buffer.new ()
+ val exn : Exn.t t =
+ {rd = let
+ open I
+ in
+ #rd string >>= (fn s =>
+ case Buffer.findSome (pass s o #rd) exns
+ of NONE => fail ("Unregistered exception constructor: " ^ s)
+ | SOME r => r)
+ end,
+ wr = fn e => case Buffer.findSome (pass e o #wr) exns
+ of NONE => GenericsUtil.failExn e
+ | SOME r => r,
+ sz = NONE}
+ fun regExn c {rd, wr, sz=_} (a2e, e2a) = let
+ val c = Generics.Con.toString c
+ val rd = I.map a2e rd
in
- share (Arg.largeInt ()) (iso' id string' (to, from))
+ (Buffer.push exns)
+ {rd = fn c' => if c' = c then SOME rd else NONE,
+ wr = Option.map (fn a => O.>> (#wr string c, wr a)) o e2a}
end
+ fun regExn0 c (e, p) = regExn c unit (const e, p)
+ fun regExn1 c t = regExn c (getT t)
+ val fixedInt = fixedInt
+ val largeInt = if isSome LargeInt.precision
+ then iso' id fixedInt (swap FixedInt.isoLarge)
+ else intInf
+
val char = char
- val bool = bool
- val int = int
- val real = bits RealWord.ops CastReal.isoBits
- val string = share (Arg.string ()) string'
- val word = bits Word.ops Iso.id
+ val bool = iso' id char (swap Char.isoInt <--> Bool.isoInt)
+ val int = if isSome Int.precision
+ then iso' id fixedInt Int.isoFixedInt
+ else iso' id largeInt Int.isoLargeInt
+ val real = bits true RealWord.ops CastReal.isoBits
+ val string = string
+ val word = mkFixedInt (swap Word.isoLargeX)
- val largeReal = bits LargeRealWord.ops CastLargeReal.isoBits
- val largeWord = bits LargeWord.ops Iso.id
+ val largeReal = bits true LargeRealWord.ops CastLargeReal.isoBits
+ val largeWord = mkFixedInt Iso.id
- val word8 = iso' id char word8Ichar
- val word32 = bits Word32.ops Iso.id
- val word64 = bits Word64.ops Iso.id)
+ val word8 = word8
+ val word32 = bits false Word32.ops Iso.id
+ val word64 = bits false Word64.ops Iso.id)
open Layered
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -110,11 +110,20 @@
val exn : Exn.t Rep.t ref =
ref (txt o "#" <\ op ^ o General.exnName o #2)
- fun regExn t (_, prj) =
+ fun regExn0 c (_, prj) =
Ref.modify (fn exn => fn (env, e) =>
case prj e
+ of NONE => exn (env, e)
+ | SOME () => txt (c2s c)) exn
+ fun regExn1 c t (_, prj) =
+ Ref.modify (fn exn => fn (env, e) =>
+ case prj e
of NONE => exn (env, e)
- | SOME x => t (env, x)) exn
+ | SOME x =>
+ nest 1 (group (txt (c2s c) <$>
+ atomize (t (env, x))))) exn
+
+
val exn = fn ? => !exn ?
val txtAs = txt "as"
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -56,8 +56,9 @@
fun op --> _ = failing "Reduce.--> has no default"
- fun regExn _ _ = ()
fun exn _ = fail "Reduce.exn not yet implemented"
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
fun list ? = seq List.foldl ?
fun vector ? = seq Vector.foldl ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -101,6 +101,8 @@
| SOME _ & NONE => SOME (e, false)
| NONE & SOME _ => SOME (e, false)
| NONE & NONE => NONE)
+ fun regExn0 _ (e, p) = regExn unit (const e, p)
+ fun regExn1 _ = regExn
fun array ? = cyclic (sequ {toSlice = ArraySlice.full,
getItem = ArraySlice.getItem} ?)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -63,7 +63,8 @@
*)
val exn = fn () => Empty
- fun regExn _ _ = ()
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
fun array _ = Array.empty
fun vector _ = Vector.empty
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -43,8 +43,9 @@
fun op --> _ = failing "Transform.--> not yet implemented"
- fun regExn _ _ = ()
fun exn _ = fail "Transform.exn not yet implemented"
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
val list = List.map
val vector = Vector.map
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -60,7 +60,8 @@
fun op --> _ = base
val exn = INT {base = true}
- fun regExn _ _ = ()
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
fun array (INT {...}) = INT {base = true}
fun refc (INT {base, ...}) = INT {base = base}
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-22 13:25:59 UTC (rev 5926)
@@ -19,14 +19,11 @@
fun C1' n = C1 (C n)
fun R' n = R (L n)
- fun regExn0 e p n = regExn (C0' n) (const e, p)
- fun regExn1 e p n t = regExn (C1' n t) (e, p)
-
local
- fun mk f e p = f e (fn e => SOME (p e) handle Match => NONE)
+ fun lift f a = SOME (f a) handle Match => NONE
in
- fun regExn0' ? = mk regExn0 ?
- fun regExn1' ? = mk regExn1 ?
+ fun regExn0' n e p = regExn0 (C n) (e, lift p)
+ fun regExn1' n t e p = regExn1 (C n) t (e, lift p)
end
local
@@ -89,31 +86,29 @@
val () = let
open IEEEReal OS OS.IO OS.Path Time
- val s = SOME
- val n = NONE
- val su = SOME ()
in
(* Handlers for most standard exceptions: *)
- regExn0 Bind (fn Bind => su | _ => n) "Bind"
- ; regExn0 Chr (fn Chr => su | _ => n) "Chr"
- ; regExn0 Date.Date (fn Date.Date => su | _ => n) "Date.Date"
- ; regExn0 Div (fn Div => su | _ => n) "Div"
- ; regExn0 Domain (fn Domain => su | _ => n) "Domain"
- ; regExn0 Empty (fn Empty => su | _ => n) "Empty"
- ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc"
- ; regExn0 Match (fn Match => su | _ => n) "Match"
- ; regExn0 Option (fn Option => su | _ => n) "Option"
- ; regExn0 Overflow (fn Overflow => su | _ => n) "Overflow"
- ; regExn0 Path (fn Path => su | _ => n) "OS.Path.Path"
- ; regExn0 Poll (fn Poll => su | _ => n) "OS.IO.Poll"
- ; regExn0 Size (fn Size => su | _ => n) "Size"
- ; regExn0 Span (fn Span => su | _ => n) "Span"
- ; regExn0 Subscript (fn Subscript => su | _ => n) "Subscript"
- ; regExn0 Time (fn Time => su | _ => n) "Time.Time"
- ; regExn0 Unordered (fn Unordered => su | _ => n) "IEEEReal.Unordered"
- ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string
+ regExn0' "Bind" Bind (fn Bind => ())
+ ; regExn0' "Chr" Chr (fn Chr => ())
+ ; regExn0' "Date.Date" Date.Date (fn Date.Date => ())
+ ; regExn0' "Div" Div (fn Div => ())
+ ; regExn0' "Domain" Domain (fn Domain => ())
+ ; regExn0' "Empty" Empty (fn Empty => ())
+ ; regExn0' "OS.Path.InvalidArc" InvalidArc (fn InvalidArc => ())
+ ; regExn0' "Match" Match (fn Match => ())
+ ; regExn0' "Option" Option (fn Option => ())
+ ; regExn0' "Overflow" Overflow (fn Overflow => ())
+ ; regExn0' "OS.Path.Path" Path (fn Path => ())
+ ; regExn0' "OS.IO.Poll" Poll (fn Poll => ())
+ ; regExn0' "Size" Size (fn Size => ())
+ ; regExn0' "Span" Span (fn Span => ())
+ ; regExn0' "Subscript" Subscript (fn Subscript => ())
+ ; regExn0' "Time.Time" Time (fn Time => ())
+ ; regExn0' "IEEEReal.Unordered" Unordered (fn Unordered => ())
+ ; regExn1' "Fail" string Fail (fn Fail ? => ?)
(* Handlers for some extended-basis exceptions: *)
- ; regExn0 Sum.Sum (fn Sum.Sum => su | _ => n) "Sum"
- ; regExn0 Fix.Fix (fn Fix.Fix => su | _ => n) "Fix"
+ ; regExn0' "IOSMonad.EOS" IOSMonad.EOS (fn IOSMonad.EOS => ())
+ ; regExn0' "Sum.Sum" Sum.Sum (fn Sum.Sum => ())
+ ; regExn0' "Fix.Fix" Fix.Fix (fn Fix.Fix => ())
end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-22 13:25:59 UTC (rev 5926)
@@ -45,7 +45,9 @@
(* Framework *)
- detail/with-extra.fun
+ ann "nonexhaustiveExnMatch ignore" in
+ detail/with-extra.fun
+ end
detail/root-generic.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -87,9 +87,12 @@
val exn : Exn.t Rep.t
(** Universal representation for exceptions. *)
- val regExn : 'a Rep.s -> ('a, Exn.t) Emb.t Effect.t
- (** Registers a handler for exceptions. *)
+ val regExn0 : Generics.Con.t -> (Exn.t * (Exn.t -> Unit.t Option.t)) Effect.t
+ (** Registers a nullary exception constructor. *)
+ val regExn1 : Generics.Con.t -> 'a Rep.t -> ('a, Exn.t) Emb.t Effect.t
+ (** Registers an unary exception constructor. *)
+
(** == Support for Types With Identity == *)
val array : 'a Rep.t -> 'a Array.t Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -28,7 +28,7 @@
(** == Framework Functors == *)
-functor CloseCases (Arg : OPEN_CASES) :
+functor CloseCases (Arg : OPEN_CASES) :>
CLOSED_CASES
where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
where type 'a Rep.s = ('a, Unit.t) Arg.Rep.s
@@ -37,7 +37,6 @@
(** Closes open structural cases. *)
signature LAYER_REP_DOM = LAYER_REP_DOM
-
functor LayerRep (Arg : LAYER_REP_DOM) :>
LAYERED_REP
where type 'a Closed.t = 'a Arg.Closed.t
@@ -53,8 +52,7 @@
*)
signature LAYER_CASES_DOM = LAYER_CASES_DOM
-
-functor LayerCases (Arg : LAYER_CASES_DOM) :
+functor LayerCases (Arg : LAYER_CASES_DOM) :>
OPEN_CASES
where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
where type ('a, 'x) Rep.s = ('a, 'x) Arg.Result.s
@@ -65,7 +63,6 @@
*)
signature LAYER_DEP_CASES_DOM = LAYER_DEP_CASES_DOM
-
functor LayerDepCases (Arg : LAYER_DEP_CASES_DOM) :>
OPEN_CASES
where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
@@ -89,7 +86,7 @@
(** == Auxiliary Generics == *)
signature DATA_REC_INFO = DATA_REC_INFO
-signature DATA_REC_INFO_CASES = DATA_REC_INFO_CASES
+ and DATA_REC_INFO_CASES = DATA_REC_INFO_CASES
functor WithDataRecInfo (Arg : OPEN_CASES) : DATA_REC_INFO_CASES =
WithDataRecInfo (Arg)
@@ -101,57 +98,49 @@
* - exception constructors are globally unique.
*)
-signature TYPE_INFO = TYPE_INFO
-signature TYPE_INFO_CASES = TYPE_INFO_CASES
+signature TYPE_INFO = TYPE_INFO and TYPE_INFO_CASES = TYPE_INFO_CASES
functor WithTypeInfo (Arg : OPEN_CASES) : TYPE_INFO_CASES = WithTypeInfo (Arg)
-(** == Generics == *)
+(** == Generics ==
+ *
+ * Although it isn't directly apparent from the "functor signatures" of
+ * the generics, they are actually sealed via the layering functors.
+ *)
-signature ARBITRARY = ARBITRARY
-signature ARBITRARY_CASES = ARBITRARY_CASES
-signature WITH_ARBITRARY_DOM = WITH_ARBITRARY_DOM
+signature ARBITRARY = ARBITRARY and ARBITRARY_CASES = ARBITRARY_CASES
+ and WITH_ARBITRARY_DOM = WITH_ARBITRARY_DOM
functor WithArbitrary (Arg : WITH_ARBITRARY_DOM) : ARBITRARY_CASES =
WithArbitrary (Arg)
-signature DYNAMIC = DYNAMIC
-signature DYNAMIC_CASES = DYNAMIC_CASES
+signature DYNAMIC = DYNAMIC and DYNAMIC_CASES = DYNAMIC_CASES
functor WithDynamic (Arg : OPEN_CASES) : DYNAMIC_CASES = WithDynamic (Arg)
-signature EQ = EQ
-signature EQ_CASES = EQ_CASES
+signature EQ = EQ and EQ_CASES = EQ_CASES
functor WithEq (Arg : OPEN_CASES) : EQ_CASES = WithEq (Arg)
-signature HASH = HASH
-signature HASH_CASES = HASH_CASES
-signature WITH_HASH_DOM = WITH_HASH_DOM
+signature HASH = HASH and HASH_CASES = HASH_CASES
+ and WITH_HASH_DOM = WITH_HASH_DOM
functor WithHash (Arg : WITH_HASH_DOM) : HASH_CASES = WithHash (Arg)
-signature ORD = ORD
-signature ORD_CASES = ORD_CASES
+signature ORD = ORD and ORD_CASES = ORD_CASES
functor WithOrd (Arg : OPEN_CASES) : ORD_CASES = WithOrd (Arg)
-signature PICKLE = PICKLE
-signature PICKLE_CASES = PICKLE_CASES
-signature WITH_PICKLE_DOM = WITH_PICKLE_DOM
+signature PICKLE = PICKLE and PICKLE_CASES = PICKLE_CASES
+ and WITH_PICKLE_DOM = WITH_PICKLE_DOM
functor WithPickle (Arg : WITH_PICKLE_DOM) : PICKLE_CASES = WithPickle (Arg)
-signature PRETTY = PRETTY
-signature PRETTY_CASES = PRETTY_CASES
+signature PRETTY = PRETTY and PRETTY_CASES = PRETTY_CASES
functor WithPretty (Arg : OPEN_CASES) : PRETTY_CASES = WithPretty (Arg)
-signature REDUCE = REDUCE
-signature REDUCE_CASES = REDUCE_CASES
+signature REDUCE = REDUCE and REDUCE_CASES = REDUCE_CASES
functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = WithReduce (Arg)
-signature SEQ = SEQ
-signature SEQ_CASES = SEQ_CASES
+signature SEQ = SEQ and 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
+signature SOME = SOME and SOME_CASES = SOME_CASES
+ and WITH_SOME_DOM = WITH_SOME_DOM
functor WithSome (Arg : WITH_SOME_DOM) : SOME_CASES = WithSome (Arg)
-signature TRANSFORM = TRANSFORM
-signature TRANSFORM_CASES = TRANSFORM_CASES
+signature TRANSFORM = TRANSFORM and TRANSFORM_CASES = TRANSFORM_CASES
functor WithTransform (Arg : OPEN_CASES) : TRANSFORM_CASES = WithTransform (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -25,16 +25,21 @@
val R' : String.t -> 'a Rep.t -> ('a, Record.t) Rep.p
- val regExn0 : Exn.t -> (Exn.t -> Unit.t Option.t) -> String.t Effect.t
- val regExn1 :
- ('a -> Exn.t) -> (Exn.t -> 'a Option.t) -> String.t -> 'a Rep.t Effect.t
+ val regExn0' : String.t -> Exn.t -> (Exn.t -> Unit.t) Effect.t
+ val regExn1' : String.t -> 'a Rep.t -> ('a -> Exn.t) -> (Exn.t -> 'a) Effect.t
- val regExn0' : Exn.t -> (Exn.t -> Unit.t) -> String.t Effect.t
- val regExn1' :
- ('a -> Exn.t) -> (Exn.t -> 'a) -> String.t -> 'a Rep.t Effect.t
+ (** == Tuples ==
+ *
+ * Note that these are provided for convenience --- generics are not
+ * limited to these tuple arities. To encode an arbitrary n-tuple, use
+ * the following pattern:
+ *
+ *> fun tupleN (t1, ..., tN) =
+ *> iso (tuple (T t1 *` ... *` T tN))
+ *> (fn (v1, ..., vN) => v1 & ... & vN,
+ *> fn v1 & ... & vN => (v1, ..., vN))
+ *)
- (** == Tuples == *)
-
val tuple2 : 'a Rep.t * 'b Rep.t -> ('a * 'b) Rep.t
val tuple3 : 'a Rep.t * 'b Rep.t * 'c Rep.t -> ('a * 'b * 'c) Rep.t
val tuple4 :
@@ -52,7 +57,13 @@
val option : 'a Rep.t -> 'a Option.t Rep.t
val order : Order.t Rep.t
- (** == Sums and Products == *)
+ (** == Binary Sums and Products ==
+ *
+ * Note that the following are not the same as the {*`} and {+`}
+ * combinators for encoding n-ary products and sums. Rather, the
+ * following encode the particular general purpose binary product
+ * and sum types provided by the Extended Basis library.
+ *)
val &` : 'a Rep.t * 'b Rep.t -> ('a, 'b) Product.t Rep.t
val |` : 'a Rep.t * 'b Rep.t -> ('a, 'b) Sum.t Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -27,7 +27,8 @@
val Y : 'a Result.Closed.t Tie.t
val --> : ('a, 'x) Result.t * ('b, 'y) Result.t -> ('a -> 'b) Result.Closed.t
val exn : Exn.t Result.Closed.t
- val regExn : ('a, 'x) Result.s -> ('a, Exn.t) Emb.t Effect.t
+ val regExn0 : Generics.Con.t -> (Exn.t * (Exn.t -> Unit.t Option.t)) Effect.t
+ val regExn1 : Generics.Con.t -> ('a, 'x) Result.t -> ('a, Exn.t) Emb.t Effect.t
val array : ('a, 'x) Result.t -> 'a Array.t Result.Closed.t
val refc : ('a, 'x) Result.t -> 'a Ref.t Result.Closed.t
val vector : ('a, 'x) Result.t -> 'a Vector.t Result.Closed.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -27,7 +27,8 @@
val Y : 'x Tie.t -> ('a, 'x) Rep.t Tie.t
val --> : ('x * 'y -> 'z) -> ('a, 'x) Rep.t * ('b, 'y) Rep.t -> ('a -> 'b, 'z) Rep.t
val exn : 'x -> (Exn.t, 'x) Rep.t
- val regExn : ('x -> ('a, Exn.t) Emb.t Effect.t) -> ('a, 'x) Rep.s -> ('a, Exn.t) Emb.t Effect.t
+ val regExn0 : (Generics.Con.t -> (Exn.t * (Exn.t -> Unit.t Option.t)) Effect.t) -> Generics.Con.t -> (Exn.t * (Exn.t -> Unit.t Option.t)) Effect.t
+ val regExn1 : (Generics.Con.t -> 'x -> ('a, Exn.t) Emb.t Effect.t) -> Generics.Con.t -> ('a, 'x) Rep.t -> ('a, Exn.t) Emb.t Effect.t
val array : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Array.t, 'y) Rep.t
val refc : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Ref.t, 'y) Rep.t
val vector : ('x -> 'y) -> ('a, 'x) Rep.t -> ('a Vector.t, 'y) Rep.t
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -11,8 +11,10 @@
* equality. For mutable types (refs and arrays) this means that two
* objects are considered equal iff they have the same identity. This
* means that the result of comparing two particular mutable objects is
- * invariant. If you truly need a structural equality relation for
- * mutable types that ignores identity, see {ORD}.
+ * invariant. If you need a structural equality relation for mutable
+ * types that merely requires objects to have one-to-one sharing, see
+ * {SEQ}. 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.
@@ -31,8 +33,8 @@
* Of course, all of this is modulo user specified morphisms!
*
* By default, comparison of exceptions only works when at least one of
- * the exception constructors involved in a comparison has been registered
- * with {regExn}.
+ * the exception constructors involved in a comparison has been
+ * registered.
*
* Comparison of functions is impossible and fails at run-time.
*)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -30,8 +30,8 @@
* non-numerical applications such as serialization.
*
* By default, comparison of exceptions only works when at least one of
- * the exception constructors involved in a comparison has been registered
- * with {regExn}.
+ * the exception constructors involved in a comparison has been
+ * registered.
*
* Comparison of functions is impossible and fails at run-time.
*)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-08-22 13:25:59 UTC (rev 5926)
@@ -7,16 +7,49 @@
(**
* Signature for a generic pickle/unpickle function.
*
- * WARNING: At the moment, pickles are not portable.
+ * WARNING: The pickle format is neither versioned nor typed. Pickling
+ * with one type and unpickling with another either fails with an
+ * exception or produces some value, which is usually not wanted.
+ *
+ * The pickle format is designed to be platform independent. For example,
+ * it is possible to pickle on a 32-bit big-endian platform and unpickle
+ * on a 64-bit little-endian platform or vice-versa. Types whose sizes
+ * are platform dependent use variable length or explicit precision
+ * encodings. Unpickling fails if an encoded value is not representable
+ * or there is no conversion from the pickled precision.
+ *
+ * The pickle format is byte-oriented (not bit-oriented) and relatively
+ * compact given the platform independency. Entropy coding is likely to
+ * be effective on pickled data, because tags in pickled data are biased
+ * towards small octets. The pickle format should admit relatively
+ * efficient pickling and unpickling, especially given a few reasonable
+ * primitives, but the current implementation is not written for
+ * efficiency. Sharing is only introduced if it possibly decreases the
+ * size of pickles or is required due to mutable data structures.
*)
signature PICKLE = sig
structure Pickle : OPEN_REP
- val pickle : ('a, 'x) Pickle.t -> (Char.t, 'b) Writer.t -> ('a, 'b) Writer.t
- (** Extracts the pickling function. *)
+ (** == Stream Interface ==
+ *
+ * The {pickler} and {unpickler} functions support pickling directly to
+ * and unpickling directly from an arbitrary stream without storing the
+ * pickle in memory as a whole.
+ *)
- val unpickle : ('a, 'x) Pickle.t -> (Char.t, 'b) Reader.t -> ('a, 'b) Reader.t
- (** Extracts the unpickling function. *)
+ val pickler : ('a, 'x) Pickle.t -> (Char.t -> (Unit.t, 's) IOSMonad.t)
+ -> ('a -> (Unit.t, 's) IOSMonad.t)
+ val unpickler : ('a, 'x) Pickle.t -> (Char.t, 's) IOSMonad.t
+ -> ('a, 's) IOSMonad.t
+
+ (** == Simplified Interface ==
+ *
+ * The {pickle} and {unpickle} functions provide a simplified interface
+ * for pickling to strings and unpickling from strings.
+ *)
+
+ val pickle : ('a, 'x) Pickle.t -> 'a -> String.t
+ val unpickle : ('a, 'x) Pickle.t -> String.t -> 'a
end
signature PICKLE_CASES = sig
Added: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -0,0 +1,40 @@
+(* 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.
+ *)
+
+val () = let
+ open Generic UnitTest
+
+ fun chkEq t =
+ (chk o all t)
+ (fn x => let
+ val p = pickle t x
+ in
+ that (eq t (x, unpickle t p))
+ end)
+
+ fun testSeq t x =
+ test (fn () => let
+ val p = pickle t x
+ in
+ verifyTrue (seq t (x, unpickle t p))
+ end)
+in
+ 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))
+
+ (title "Generic.Pickle.Cyclic")
+
+ (testSeq (Graph.t int) Graph.intGraph1)
+ (testSeq (array exn) ExnArray.exnArray1)
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Copied: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml (from rev 5871, mltonlib/trunk/com/ssh/misc-util/unstable/show-test.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/show-test.sml 2007-08-14 08:18:30 UTC (rev 5871)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -0,0 +1,96 @@
+(* 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.
+ *)
+
+val () = let
+ open Generic UnitTest
+
+ infix |`
+
+ fun tst n t s v =
+ testEq string (fn () => {expect = s, actual = pretty n t v})
+in
+ unitTests
+ (title "Generic.Pretty")
+
+ (tst NONE unit "()" ())
+
+ (tst NONE word "0wx15" 0wx15)
+
+ (tst (SOME 6) (list int)
+ "[1,\n 2,\n 3]"
+ [1, 2, 3])
+
+ (tst (SOME 2) (vector bool)
+ "#[true,\n\
+ \ false]"
+ (Vector.fromList [true, false]))
+
+ (tst (SOME 15) (tuple3 (option unit, string, exn))
+ "(NONE,\n\
+ \ \"a\",\n\
+ \ Empty)"
+ (NONE, "a", Empty))
+
+ (tst NONE (array unit) "#()" (Array.array (0, ())))
+
+ (tst NONE real "~3.141" ~3.141)
+
+ (tst (SOME 22)
+ ((order |` unit) &` order &` (unit |` order))
+ "&\n\
+ \ (& (INL LESS, EQUAL),\n\
+ \ INR GREATER)"
+ (INL LESS & EQUAL & INR GREATER))
+
+ let
+ fun chk s e = tst (SOME 11) string e s
+ in
+ fn ? =>
+ (pass ?)
+ (chk "does not fit" "\"does not fit\"")
+ (chk "does\nnot\nfit" "\"does\\n\\\n\\not\\n\\\n\\fit\"")
+ (chk "does fit" "\"does fit\"")
+ (chk "does\nfit" "\"does\\nfit\"")
+ end
+
+ let
+ exception Unknown
+ in
+ tst NONE exn "#Unknown" Unknown
+ end
+
+ (tst (SOME 9)
+ (iso (record (R' "1" int
+ *` R' "+" (unOp int)
+ *` R' "c" char))
+ (fn {1 = a, + = b, c = c} => a & b & c,
+ fn a & b & c => {1 = a, + = b, c = c}))
+ "{1 = 2,\n\
+ \ + = #fn,\n\
+ \ c =\n\
+ \ #\"d\"}"
+ {1 = 2, + = id, c = #"d"})
+
+ let
+ datatype s = S of s Option.t Ref.t Sq.t
+ val x as S (l, r) = S (ref NONE, ref NONE)
+ val () = (l := SOME x ; r := SOME x)
+ in
+ tst (SOME 50)
+ (Tie.fix Y
+ (fn s =>
+ iso (data (C1' "S" (sq (refc (option s)))))
+ (fn S ? => ?, S)))
+ "S\n\
+ \ (#0 as ref\n\
+ \ (SOME (S (#0, #1 as ref (SOME (S (#0, #1)))))),\n\
+ \ #0 as ref\n\
+ \ (SOME (S (#1 as ref (SOME (S (#1, #0))), #0))))"
+ x
+ end
+
+ $
+end
Added: mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml 2007-08-22 13:25:59 UTC (rev 5926)
@@ -0,0 +1,70 @@
+(* 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.
+ *)
+
+(* Some tests need the structural/sharing equality {Seq}. *)
+structure Generic = struct
+ open Generic
+ local
+ structure Open = WithSeq (Open)
+ structure Closed = CloseCases (Open)
+ structure Extra = WithExtra (structure Open = Open open Open Closed)
+ in
+ val seq = Open.seq
+ open Extra
+ end
+end
+
+(* A simplistic graph for testing with cyclic data. *)
+structure Graph :> sig
+ type 'a t
+ val t : 'a Generic.Rep.t -> 'a t Generic.Rep.t
+ val intGraph1 : Int.t t
+end = struct
+ datatype 'a t = VTX of 'a * 'a t List.t Ref.t
+
+ local
+ open Tie Generic
+ val vtx = C "VTX"
+ in
+ fun t a =
+ fix Y (fn aT =>
+ iso (data (C1 vtx (tuple2 (a, refc (list aT)))))
+ (fn VTX ? => ?, VTX))
+ end
+
+ fun arcs (VTX (_, r)) = r
+
+ val intGraph1 = let
+ val a = VTX (1, ref [])
+ val b = VTX (2, ref [])
+ val c = VTX (3, ref [])
+ val d = VTX (4, ref [])
+ val e = VTX (5, ref [])
+ val f = VTX (6, ref [])
+ in
+ arcs a := [b, d]
+ ; arcs b := [c, e]
+ ; arcs c := [a, f]
+ ; arcs d := [f]
+ ; arcs e := [d]
+ ; arcs f := [e]
+ ; a
+ end
+end
+
+(* A contrived recursive exception constructor for testing with cyclic data. *)
+structure ExnArray :> sig
+ exception ExnArray of Exn.t Array.t
+ val exnArray1 : Exn.t Array.t
+end = struct
+ open Generic
+
+ exception ExnArray of Exn.t Array.t
+ val () = regExn1' "ExnArray" (array exn) ExnArray (fn ExnArray ? => ?)
+
+ val exnArray1 = Array.fromList [Empty]
+ val () = Array.update (exnArray1, 0, ExnArray exnArray1)
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/test-utils.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-08-22 12:49:15 UTC (rev 5925)
+++ mltonlib/trunk/com/ssh/generic
More information about the MLton-commit
mailing list