Menu
▾
▴
[MLton-commit] r4984
|
From: Wesley T. <we...@ml...> - 2006-12-18 18:56:35
|
my collection of SML libs, only half finished mostly
----------------------------------------------------------------------
A mltonlib/trunk/ca/terpstra/pickle/
A mltonlib/trunk/ca/terpstra/pickle/Makefile
A mltonlib/trunk/ca/terpstra/pickle/README
A mltonlib/trunk/ca/terpstra/pickle/ast.sml
A mltonlib/trunk/ca/terpstra/pickle/export.sml
A mltonlib/trunk/ca/terpstra/pickle/gen.sml
A mltonlib/trunk/ca/terpstra/pickle/import.sml
A mltonlib/trunk/ca/terpstra/pickle/lib/
A mltonlib/trunk/ca/terpstra/pickle/lib/binary.sml
A mltonlib/trunk/ca/terpstra/pickle/lib/pickle.mlb
A mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sig
A mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sml
A mltonlib/trunk/ca/terpstra/pickle/lib/text.sml
A mltonlib/trunk/ca/terpstra/pickle/main.sml
A mltonlib/trunk/ca/terpstra/pickle/method.sml
A mltonlib/trunk/ca/terpstra/pickle/pickle.mlb
A mltonlib/trunk/ca/terpstra/pickle/tag.sml
A mltonlib/trunk/ca/terpstra/pickle/tests/
A mltonlib/trunk/ca/terpstra/pickle/tests/Makefile
A mltonlib/trunk/ca/terpstra/pickle/tests/double.test
A mltonlib/trunk/ca/terpstra/pickle/tests/rebind.test
A mltonlib/trunk/ca/terpstra/pickle/tests/recursive.test
A mltonlib/trunk/ca/terpstra/pickle/tests/scope.test
A mltonlib/trunk/ca/terpstra/pickle/tests/tree.test
A mltonlib/trunk/ca/terpstra/pickle/tml.grm
A mltonlib/trunk/ca/terpstra/pickle/tml.lex
A mltonlib/trunk/ca/terpstra/pickle/tree.sml
A mltonlib/trunk/ca/terpstra/pickle/type.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/ca/terpstra/pickle/Makefile
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/Makefile 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/Makefile 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,22 @@
+TARGETS = pickle
+
+all: $(TARGETS)
+
+clean:
+ rm -f *.grm.* *.lex.* *.dep $(TARGETS)
+
+%.dep: %.mlb
+ echo -en "$(basename $@) $@:\t" > $@.tmp
+ mlton -stop f $< | sed 's/^/ /;s/$$/ \\/' >> $@.tmp
+ mv $@.tmp $@
+
+%: %.mlb
+ mlton -output $@ $<
+
+%.grm.sml %.grm.sig %.grm.desc: %.grm
+ mlyacc $<
+
+%.lex.sml: %.lex
+ mllex $<
+
+-include $(patsubst %.mlb,%.dep,$(wildcard *.mlb))
Added: mltonlib/trunk/ca/terpstra/pickle/README
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/README 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/README 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,10 @@
+Since MLton has no automatic serialization capability, this attempts to
+build one as a library. The idea was that a protocol could be specified as
+a SML type and the compiled into a serializer for C and SML.
+
+The serializers are built as functors. This way they can be instantiated on
+a binary or text serializer for basic types.
+
+Compile the compiler with:
+ make
+The test directory includes example SML types suitable for compilation
Added: mltonlib/trunk/ca/terpstra/pickle/ast.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/ast.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/ast.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,34 @@
+type tyvar = string
+type tag = string
+
+(* Types which can be written down without a declaration: *)
+datatype inline_typ = RECORD of (string * inline_typ) vector
+ | RECURSIVE of string * (inline_typ * tag) vector * tag
+ | TUPLE of inline_typ vector
+ | TYVAR of tyvar * tag * tag
+
+(* At the top-level, the most general declaration looks like:
+ *
+ * datatype d1 = C of d1 | D of d2 | E of t1
+ * and d2 = F of d1 | G of d2 | F of t2
+ * withtypes t1 = string * d2
+ * and t2 = t1 (* the OLD binding of t1, not the one above *)
+ *
+ * The datatypes are evaluated within the scope of the withtypes and
+ * the other datatypes.
+ *
+ * The withtypes are evaluated within the scope of the datatypes (but
+ * not of the other withtypes).
+ *
+ * An entire such clause is a 'toplevel_typ' below
+ *)
+
+type data_typ = tag * tag * (string * inline_typ option) vector
+
+type 'a bind_typ = { name : string,
+ reader : string,
+ writer : string,
+ tyvars : (tyvar * tag) vector,
+ typ : 'a }
+
+type toplevel_typ = data_typ bind_typ vector * inline_typ bind_typ vector
Added: mltonlib/trunk/ca/terpstra/pickle/export.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/export.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/export.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,22 @@
+fun export ((data, bind), (l, scope)) =
+ let
+ fun decl { name, reader=_, writer=_, tyvars, typ=_ } l =
+ l && " type " ++ tuple (#1, tyvars) && name && "\n"
+ fun binder ({ name, reader=_, writer=_, tyvars=_, typ=_ }, m) =
+ Map.insert m (name, { reader = "", writer = "" })
+
+ val l = l ++ foldl (decl, bind)
+ val scope = Vector.foldl binder scope bind
+ val (l, scope) = dtype ((data, Vector.fromList []), (l, scope))
+
+ fun typack rw (t, _) l = l && t && " Base." && rw
+ fun tyfun rw v l =
+ if Vector.length v = 0 then l else
+ l ++ sfoldl (typack rw, " * ", v) && " -> " ++ tuple (#1, v)
+ fun methods {name, reader=_, writer=_, tyvars, typ=_} l =
+ l && " val " && name
+ && ": { r: " ++ tyfun "r" tyvars && name && " Base.r, w: "
+ ++ tyfun "w" tyvars && name && " Base.w }\n"
+ in
+ (l ++ foldl (methods, data) ++ foldl (methods, bind), scope)
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/gen.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/gen.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/gen.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,30 @@
+ structure Order = struct type k = string val order = String.compare end
+structure Set = Set(Order)
+structure Map = Map(Order)
+
+infix 5 && ++
+fun l && x = x :: l
+fun l ++ f = f l
+
+fun foldl (f, v) l = Vector.foldl (fn (x, l) => f x l) l v
+fun foldli (f, v) l = Vector.foldli (fn (i, x, l) => f (i, x) l) l v
+fun sfoldl (f, s, v) l =
+ let
+ fun sep (0, s) = ""
+ | sep (_, s) = s
+ fun gen (i, x, l) = l && sep (i, s) ++ f x
+ in
+ Vector.foldli gen l v
+ end
+
+fun tuple (f, v) l =
+ if Vector.length v = 0 then l else
+ l && "(" ++ sfoldl (fn x => fn l => l && f x, ", ", v) && ") "
+
+local
+ fun bindToKey { name, reader, writer, tyvars=_, typ=_ } =
+ (name, { reader = reader, writer = writer })
+in
+ fun defd (bind:'a bind_typ vector) =
+ Map.fromVector (Vector.map bindToKey bind)
+end
Added: mltonlib/trunk/ca/terpstra/pickle/import.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/import.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/import.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,58 @@
+fun import ((data, bind) : toplevel_typ, (l, scope)) =
+ let
+ val withscope = Map.union (scope, defd data)
+ val datascope = Map.union (withscope, defd bind)
+ val imports = ref Set.empty
+
+ fun refd (typ, map) =
+ case typ of
+ (RECORD v) => Vector.foldl refd map (Vector.map #2 v)
+ | (TUPLE v) => Vector.foldl refd map v
+ | (TYVAR _) => map
+ | (RECURSIVE (n, v, _)) =>
+ Vector.foldl refd
+ (Map.insert map (n, Vector.length v))
+ (Vector.map #1 v)
+
+ fun prune scope map =
+ let
+ fun filter ((k, v), m) =
+ case Map.fetch scope k of
+ NONE => Map.insert m (k, v)
+ | SOME _ => m
+ in
+ Map.foldl filter Map.empty map
+ end
+
+ val withtyp = Vector.map #typ bind
+ val datatyp = Vector.map #typ data
+ val withref = prune withscope (Vector.foldl refd Map.empty withtyp)
+ fun constr ((_, NONE), m) = m
+ | constr ((_, SOME typ), m) = refd (typ, m)
+ fun datav ((_, _, v), m) = Vector.foldl constr m v
+ val dataref = prune datascope (Vector.foldl datav Map.empty datatyp)
+
+ val import = Map.union (dataref, withref)
+
+ fun fakescope ((k, _), m) = Map.insert m (k, {reader = "", writer = ""})
+ val outscope = Map.foldl fakescope datascope import
+
+ fun tyvar 1 l = l && "'a1"
+ | tyvar i l = l && "'a" && Int.toString i && ", " ++ tyvar (i - 1)
+ fun tyvars n l =
+ if n = 0 then l else
+ l && "(" ++ tyvar n && ") "
+ fun tyarg rw 1 l = l && "'a1 Base." && rw
+ | tyarg rw i l = l && "'a" && Int.toString i && " Base." && rw && " * "
+ ++ tyarg rw (i - 1)
+ fun tyfun rw n l =
+ if n = 0 then l else
+ l ++ tyarg rw n && " -> " ++ tyvars n
+
+ fun declare ((k, v), l) =
+ l && " type " ++ tyvars v && k && "\n"
+ && " val " && k && ": { r: " ++ tyfun "r" v && k
+ && " Base.r, w: " ++ tyfun "w" v && k && " Base.w }\n"
+ in
+ (Map.foldl declare l import, outscope)
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/lib/binary.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/lib/binary.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/lib/binary.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,66 @@
+structure Binary : PICKLER =
+ struct
+ exception Corrupt
+
+ structure Base =
+ struct
+ type wt = Word8.word list
+ type rt = Word8.word list
+ type 'a r = rt -> rt * 'a
+ type 'a w = wt * 'a -> wt
+
+ val opts = { r = fn _ => fn (a :: r) => (r, Word8.toInt a) | _ => raise Corrupt,
+ w = fn _ => fn (l, i) => Word8.fromInt i :: l }
+ end
+
+ type t = Word8Vector.vector
+ val eof = []
+ val convert = { w = Word8Vector.fromList o rev,
+ r = fn v => List.tabulate
+ (Word8Vector.length v, fn i => Word8Vector.sub (v, i)) }
+
+ type unit = unit
+ type bool = bool
+ type char = char
+ type word = word
+ type int = int
+ type string = string
+ type 'a vector = 'a vector
+
+ val unit = { r = fn l => (l, ()), w = fn (l, _) => l }
+ val bool = { r = fn ((a:Word8.word) :: r) => (r, 0w0 <> a) | _ => raise Corrupt,
+ w = fn (l, b) => (if b then (0w1:Word8.word) else 0w0) :: l }
+ val char = { r = fn (a :: r) => (r, Char.chr (Word8.toInt a)) | _ => raise Corrupt,
+ w = fn (l, c) => Word8.fromInt (Char.ord c) :: l }
+
+ val (w2s, s2w) = (Word8.fromInt o Word.toInt, Word.fromInt o Word8.toInt)
+ val (<<, >>, orb) = (Word.<<, Word.>>, Word.orb)
+ infix 5 << >>
+ infix 4 orb
+ val word = { r = fn (w0 :: w1 :: w2 :: w3 :: r) =>
+ (r, s2w w0 << 0w24 orb s2w w1 << 0w16 orb s2w w2 << 0w8 orb s2w w3)
+ | _ => raise Corrupt,
+ w = fn (l, w) =>
+ w2s w :: w2s (w >> 0w8) :: w2s (w >> 0w16) :: w2s (w >> 0w24) :: l }
+ val int = { r = fn l => let val (r, w) = #r word l in (r, Word.toInt w) end,
+ w = fn (l, i) => #w word (l, Word.fromInt i) }
+
+ fun rstring l =
+ let
+ val (l, i) = #r int l
+ val (s, l) = (List.take (l, i), List.drop (l, i))
+ val s = List.map (Char.chr o Word8.toInt) s
+ val s = implode s
+ in
+ (l, s)
+ end
+ fun wstring (l, s) =
+ List.map (Word8.fromInt o Char.ord) (rev (explode s))
+ @ #w int (l, String.size s)
+
+ fun rvector f l = (l, Vector.fromList [])
+ fun wvector f (l, v) = l (*!!! buggy *)
+
+ val string = { r = rstring, w = wstring }
+ val vector = { r = rvector, w = wvector }
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/lib/pickle.mlb
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/lib/pickle.mlb 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/lib/pickle.mlb 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,8 @@
+local
+ $(SML_LIB)/basis/basis.mlb
+in
+ pickle.sig
+ pickle.sml
+ binary.sml
+ text.sml
+end
Added: mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sig 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sig 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,56 @@
+signature PICKLER_BASE =
+ sig
+ type rt
+ type wt
+ type 'a r = rt -> rt * 'a
+ type 'a w = wt * 'a -> wt
+ val opts: { r: int -> int r, w: int -> int w }
+ end
+
+signature PICKLER_SIMPLE =
+ sig
+ structure Base : PICKLER_BASE
+ type t
+
+ val eof: Base.wt
+ val convert: { r: t -> Base.rt, w: Base.wt -> t }
+ end
+
+signature PICKLER =
+ sig
+ include PICKLER_SIMPLE
+
+ type unit = unit
+ type bool = bool
+ type char = char
+ type word = word
+ type int = int
+ type string = string
+ type 'a vector = 'a vector
+
+ (* real, substring, exn, 'a array, 'a list, 'a ref, 'a array, order, 'a option *)
+ val unit: { r: unit Base.r, w: unit Base.w }
+ val bool: { r: bool Base.r, w: bool Base.w }
+ val char: { r: char Base.r, w: char Base.w }
+ val word: { r: word Base.r, w: word Base.w }
+ val int: { r: int Base.r, w: int Base.w }
+ val string: { r: string Base.r, w: string Base.w }
+ val vector: { r: 'a Base.r -> 'a vector Base.r,
+ w: 'a Base.w -> 'a vector Base.w }
+ end
+
+signature PICKLE =
+ sig
+ structure Base : PICKLER_BASE
+
+ type t
+ type 'a pickle = { r: 'a Base.r, w: 'a Base.w }
+
+ val compose1: { r: 'a Base.r -> 'b Base.r, w: 'a Base.w -> 'b Base.w }
+ -> 'a pickle -> 'b pickle
+ val compose2: { r: 'a1 Base.r * 'a2 Base.r -> 'b Base.r,
+ w: 'a1 Base.w * 'a2 Base.w -> 'b Base.w }
+ -> 'a1 pickle * 'a2 pickle -> 'b pickle
+
+ val pickle: 'a pickle -> { r: t -> 'a, w: 'a -> t }
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/lib/pickle.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,14 @@
+functor Pickle(P : PICKLER_SIMPLE) :> PICKLE =
+ struct
+ structure Base = P.Base
+ type 'a pickle = { r: 'a Base.r, w: 'a Base.w }
+ type t = P.t
+
+ fun compose1 {r=rf, w=wf} {r=r1, w=w1} = {r=rf r1, w=wf w1}
+ fun compose2 {r=rf, w=wf} ({r=r1, w=w1}, {r=r2, w=w2}) = {r=rf(r1,r2), w=wf(w1,w2)}
+
+ fun pickle ({r, w}: 'a pickle) =
+ { r = fn t => (#2 o r o (#r P.convert)) t,
+ w = fn x => (#w P.convert) (w (P.eof, x)) }
+ end
+
\ No newline at end of file
Added: mltonlib/trunk/ca/terpstra/pickle/lib/text.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/lib/text.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/lib/text.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,66 @@
+structure Binary : PICKLER =
+ struct
+ exception Corrupt
+
+ structure Base =
+ struct
+ type wt = Word8.word list
+ type rt = Word8.word list
+ type 'a r = rt -> rt * 'a
+ type 'a w = wt * 'a -> wt
+
+ val opts = { r = fn _ => fn (a :: r) => (r, Word8.toInt a) | _ => raise Corrupt,
+ w = fn _ => fn (l, i) => Word8.fromInt i :: l }
+ end
+
+ type t = Word8Vector.vector
+ val eof = []
+ val convert = { w = Word8Vector.fromList o rev,
+ r = fn v => List.tabulate
+ (Word8Vector.length v, fn i => Word8Vector.sub (v, i)) }
+
+ type unit = unit
+ type bool = bool
+ type char = char
+ type word = word
+ type int = int
+ type string = string
+ type 'a vector = 'a vector
+
+ val unit = { r = fn l => (l, ()), w = fn (l, _) => l }
+ val bool = { r = fn ((a:Word8.word) :: r) => (r, 0w0 <> a) | _ => raise Corrupt,
+ w = fn (l, b) => (if b then (0w1:Word8.word) else 0w0) :: l }
+ val char = { r = fn (a :: r) => (r, Char.chr (Word8.toInt a)) | _ => raise Corrupt,
+ w = fn (l, c) => Word8.fromInt (Char.ord c) :: l }
+
+ val (w2s, s2w) = (Word8.fromInt o Word.toInt, Word.fromInt o Word8.toInt)
+ val (<<, >>, orb) = (Word.<<, Word.>>, Word.orb)
+ infix 5 << >>
+ infix 4 orb
+ val word = { r = fn (w0 :: w1 :: w2 :: w3 :: r) =>
+ (r, s2w w0 << 0w24 orb s2w w1 << 0w16 orb s2w w2 << 0w8 orb s2w w3)
+ | _ => raise Corrupt,
+ w = fn (l, w) =>
+ w2s w :: w2s (w >> 0w8) :: w2s (w >> 0w16) :: w2s (w >> 0w24) :: l }
+ val int = { r = fn l => let val (r, w) = #r word l in (r, Word.toInt w) end,
+ w = fn (l, i) => #w word (l, Word.fromInt i) }
+
+ fun rstring l =
+ let
+ val (l, i) = #r int l
+ val (s, l) = (List.take (l, i), List.drop (l, i))
+ val s = List.map (Char.chr o Word8.toInt) s
+ val s = implode s
+ in
+ (l, s)
+ end
+ fun wstring (l, s) =
+ List.map (Word8.fromInt o Char.ord) (rev (explode s))
+ @ #w int (l, String.size s)
+
+ fun rvector f l = (l, Vector.fromList [])
+ fun wvector f (l, v) = l (*!!! buggy *)
+
+ val string = { r = rstring, w = wstring }
+ val vector = { r = rvector, w = wvector }
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/main.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/main.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/main.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,66 @@
+fun prerr s =
+ TextIO.outputSubstr (TextIO.stdErr, Substring.full s)
+fun help () = (
+ prerr "Usage: pickle {functor-name} < {input-file} > {output-file}\n";
+ OS.Process.exit OS.Process.failure)
+
+structure LrVals = TMLLrValsFun(structure Token = LrParser.Token)
+structure Lex = TMLLexFun(structure Tokens = LrVals.Tokens)
+structure Parse = Join(structure ParserData = LrVals.ParserData
+ structure Lex = Lex
+ structure LrParser = LrParser)
+
+val name =
+ case CommandLine.arguments () of
+ (x :: []) => x
+ | (x :: r) => ""
+ | [] => ""
+val () = if name = "" then help () else ()
+
+fun signame s =
+ let
+ fun chr (i, c, t) =
+ if i <> 0 andalso Char.isUpper c andalso
+ not (Char.isUpper (String.sub (s, i - 1)))
+ then #"_" :: Char.toUpper c :: t
+ else Char.toUpper c :: t
+ in
+ implode (CharVector.foldri chr [] s)
+ end
+
+val argname = signame name ^ "_ARG"
+val signame = signame name
+
+fun error (s, (), ()) = print ("Error: " ^ s ^ "\n")
+fun reader _ =
+ case TextIO.inputLine TextIO.stdIn of
+ SOME x => x
+ | NONE => ""
+
+val stream = Parse.makeLexer reader
+val lookahead = 30
+val ast = #1 (Parse.parse (lookahead, stream, error, ()))
+val (start, ast) = tag ast
+
+fun dump l = List.app print (List.rev l)
+fun rungen f = #1 (List.foldl f ([], Map.empty) ast)
+
+val () = (
+ print ("signature " ^ argname ^ " =\n");
+ print (" sig\n");
+ print (" structure Base : SERIAL_BASE\n");
+ dump (rungen import);
+ print (" end\n\n");
+ print ("signature " ^ signame ^ " =\n");
+ print (" sig\n");
+ print (" structure Base : SERIAL_BASE\n");
+ print (" structure Arg : " ^ argname ^ "\n");
+ dump (rungen export);
+ print (" end\n\n");
+ print ("functor " ^ name ^ "(Arg : " ^ argname ^ ") : " ^ signame ^ " =\n");
+ print (" struct\n");
+ print (" structure Base = Arg.Base\n");
+ print (" structure Arg = Arg\n");
+ print (" exception Corrupt\n");
+ dump (rungen (method start));
+ print (" end\n"))
Added: mltonlib/trunk/ca/terpstra/pickle/method.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/method.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/method.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,126 @@
+local
+ fun record (n, typ) l = l && n && "=" ++ inline typ
+ and inline node l =
+ case node of
+ (RECORD v) =>
+ l && "{ " ++ sfoldl (record, ", ", v) && " }"
+ | (RECURSIVE (_, _, t)) => l && t
+ | (TUPLE v) =>
+ l && "(" ++ sfoldl (inline, ", ", v) && ")"
+ | (TYVAR (_, t, _)) => l && t
+in
+ val pattern = inline
+end
+
+fun method start (arg as ((data, bind), (l, scope))) =
+ let
+ val withscope = Map.union (scope, defd data)
+ val datascope = Map.union (withscope, defd bind)
+ exception Undefined
+
+ fun mapOpt (f, NONE) l = l
+ | mapOpt (f, SOME x) l = l ++ f x
+
+ fun data_opts { typ = (ropt, wopt, v), ... } l =
+ l && "val (" && ropt && ", " && wopt && ") = ((#r Base.opts) "
+ && Int.toString (Vector.length v) && ", (#w Base.opts) "
+ && Int.toString (Vector.length v) && ")\n"
+
+ fun write_inline scope =
+ let
+ fun fnhelper (typ, f) l =
+ l && " fun " && f && " (a, " ++ pattern typ && ") =\n"
+ && " let\n val a = a\n" ++ inline typ
+ && " in\n a\n end\n"
+ and invoke n l =
+ case Map.fetch scope n of
+ NONE => l && "(#w Arg." && n && ")"
+ | (SOME {reader=_, writer}) => l && writer
+ and inline node l =
+ case node of
+ (RECORD v) => l ++ foldl (inline o #2, v)
+ | (TUPLE v) => l ++ foldl (inline, v)
+ | (TYVAR (_, t, f)) =>
+ l && " val a = " && f && " (a, " && t && ")\n"
+ | (RECURSIVE (n, v, t)) =>
+ l ++ foldl (fnhelper, v) && " val a = "
+ ++ invoke n && " "
+ ++ tuple (#2, v) && "(a, " && t && ")\n"
+ in
+ inline
+ end
+
+ fun write_bind { name=_, reader=_, writer, tyvars, typ } l =
+ l && "and " && writer ++ tuple (#2, tyvars)
+ && " (a, " ++ pattern typ && ") =\n"
+ && " let\n val a = a\n" ++ write_inline withscope typ
+ && " in\n a\n end\n"
+
+ fun write_data { name=_, reader=_, writer, tyvars, typ = (_, wopt, v) } l =
+ let
+ fun constr (opt, (constr, typo)) l =
+ l && (if opt = 0 then " " else "| ")
+ && "(" && constr && " " ++ mapOpt (pattern, typo) && ") =>\n"
+ && " let\n val a = " && wopt && " (a, " && Int.toString opt && ")\n"
+ ++ mapOpt (write_inline datascope, typo) && " in\n a\n end\n"
+ in
+ l && "and " && writer && " " ++ tuple (#2, tyvars)
+ && "(a, x) = case x of\n"
+ ++ foldli (constr, v)
+ end
+
+ fun read_inline scope =
+ let
+ fun fnhelper (typ, f) l =
+ l && " fun " && f && " a =\n let\n"
+ && " val a = a\n" ++ inline typ && " in\n (a, "
+ ++ pattern typ && ")\n end\n"
+ and invoke n l =
+ case Map.fetch scope n of
+ NONE => l && "(#r Arg." && n && ")"
+ | (SOME {reader, writer=_}) => l && reader
+ and inline node l =
+ case node of
+ (RECORD v) => l ++ foldl (inline o #2, v)
+ | (TUPLE v) => l ++ foldl (inline, v)
+ | (TYVAR (_, t, f)) =>
+ l && " val (a, " && t && ") = " && f && " a\n"
+ | (RECURSIVE (n, v, t)) =>
+ l ++ foldl (fnhelper, v) && " val (a, " && t
+ && ") = " ++ invoke n && " " ++ tuple (#2, v) && "a\n"
+ in
+ inline
+ end
+
+ fun read_bind { name=_, reader, writer=_, tyvars, typ } l =
+ l && "and " && reader && " " ++ tuple (#2, tyvars) && "a =\n"
+ && " let\n val a = a\n" ++ read_inline withscope typ && " in\n"
+ && " (a, " ++ pattern typ && ")\n end\n"
+
+ fun read_data { name=_, reader, writer=_, tyvars, typ = (ropt, _, v) } l =
+ let
+ fun constr (opt, (constr, typo)) l =
+ l && (if opt = 0 then " " else "| ")
+ && "(a, " && Int.toString opt && ") =>\n"
+ && " let\n val a = a\n"
+ ++ mapOpt (read_inline datascope, typo)
+ && " in\n (a, " && constr && " "
+ ++ mapOpt (pattern, typo) && ")\n end\n"
+ in
+ l && "and " && reader && " " ++ tuple (#2, tyvars) && "a =\n"
+ && "case " && ropt && " a of\n"
+ ++ foldli (constr, v) && "| (a, _) => raise Corrupt\n"
+ end
+
+ fun binds {name, reader, writer, tyvars=_, typ=_} l =
+ l && "val " && name && " = "
+ && " { r = " && reader && ", w = " && writer && " }\n"
+ in
+ (#1 (dtype arg)
+ ++ foldl (data_opts, data)
+ && "fun " && start && " x = x\n"
+ ++ foldl (write_bind, bind) ++ foldl (write_data, data)
+ ++ foldl ( read_bind, bind) ++ foldl ( read_data, data)
+ ++ foldl (binds, bind) ++ foldl (binds, data),
+ datascope)
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/pickle.mlb
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/pickle.mlb 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/pickle.mlb 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,17 @@
+local
+ $(SML_LIB)/basis/basis.mlb
+ $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb
+in
+ tree.sml
+ ast.sml
+ tml.grm.sig
+ tml.lex.sml
+ tml.grm.sml
+ gen.sml
+ tag.sml
+ type.sml
+ import.sml
+ export.sml
+ method.sml
+ main.sml
+end
Added: mltonlib/trunk/ca/terpstra/pickle/tag.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tag.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tag.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,57 @@
+fun tag ast =
+ let
+ fun topdefd ((data, bind), m) =
+ Map.union (Map.union (m, defd bind), defd data)
+ fun toSet m = Map.foldl (fn ((k, _), s) => Set.insert s k) Set.empty m
+ val ids = ref (toSet (List.foldl topdefd Map.empty ast))
+
+ val c = ref 0
+ fun pick pfx () =
+ let
+ val id = pfx ^ Int.toString (!c)
+ val () = c := (!c) + 1
+ in
+ if Set.member (!ids) id then pick pfx () else
+ id before ids := Set.insert (!ids) id
+ end
+ val pickId = pick "v_"
+ val pickFn = pick "f_"
+
+ fun tymap tyvars = Vector.map (fn (x, _) => (x, pickFn ())) tyvars
+ fun findFn tyvars n =
+ let
+ exception UnboundTyvar
+ val x = Vector.find (fn (m, _) => n = m) tyvars
+ in
+ case x of
+ NONE => raise UnboundTyvar
+ | SOME (_, f) => f
+ end
+
+ fun inline tyvars typ =
+ case typ of
+ (RECORD v) =>
+ RECORD (Vector.map (fn (n, t) => (n, inline tyvars t)) v)
+ | (TUPLE v) =>
+ TUPLE (Vector.map (inline tyvars) v)
+ | (TYVAR (tyvar, _, _)) =>
+ TYVAR (tyvar, pickId (), findFn tyvars tyvar)
+ | (RECURSIVE (name, tyv, _)) =>
+ RECURSIVE (name, Vector.map (maprec tyvars) tyv, pickId ())
+ and maprec tyvars (ty, _) = (inline tyvars ty, pickFn ())
+
+ fun bindtyp f { name, reader, writer, tyvars, typ } =
+ let val tyvars = tymap tyvars
+ in { name = name, reader = pickFn (), writer = pickFn (),
+ tyvars = tyvars, typ = f tyvars typ } end
+
+ fun datatyp tyvars (_, _, v) =
+ (pickFn (), pickFn (), Vector.map
+ (fn (name, inlineo) => (name, Option.map (inline tyvars) inlineo))
+ v)
+
+ fun process (data, bind) =
+ (Vector.map (bindtyp datatyp) data, Vector.map (bindtyp inline) bind)
+ in
+ (pickFn (), List.map process ast)
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/tests/Makefile
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/Makefile 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/Makefile 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,13 @@
+TARGETS = $(patsubst %.test,%,$(wildcard *.test))
+
+all: $(TARGETS)
+clean:
+ rm -f *.sml $(TARGETS)
+
+%.sml: %.test
+ cp ../sb.sig $@.tmp
+ ../pickle Test < $< >> $@.tmp
+ mv $@.tmp $@
+
+%: %.sml
+ mlton $<
Added: mltonlib/trunk/ca/terpstra/pickle/tests/double.test
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/double.test 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/double.test 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,2 @@
+datatype ('a, 'b) union = LEFT of 'a | RIGHT of 'b
+type ('a, 'b) pair = 'a * 'b
Added: mltonlib/trunk/ca/terpstra/pickle/tests/rebind.test
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/rebind.test 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/rebind.test 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,10 @@
+(* use old binding *)
+type pair = string * int
+
+(* flip bindings *)
+type int = string
+and string = int
+
+datatype opt =
+ VECTOR of opt * string * int
+ | NADA of opt * pair
Added: mltonlib/trunk/ca/terpstra/pickle/tests/recursive.test
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/recursive.test 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/recursive.test 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1 @@
+type 'a x = 'a vector list set
Added: mltonlib/trunk/ca/terpstra/pickle/tests/scope.test
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/scope.test 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/scope.test 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,7 @@
+(* Note that {} and unit are different because unit can be rebound *)
+datatype d1 = C of { baz : d1 * int } list | D of {} | E of t1
+and d2 = F of d1 | G of d2 | Q of t2
+withtype t1 = string * d2
+and t2 = string * unit
+
+datatype 'a d3 = datatype list
Added: mltonlib/trunk/ca/terpstra/pickle/tests/tree.test
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tests/tree.test 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tests/tree.test 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,2 @@
+datatype color = RED | BLACK
+datatype 'a tree = LEAF | NODE of color * 'a tree * 'a * 'a tree
Added: mltonlib/trunk/ca/terpstra/pickle/tml.grm
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tml.grm 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tml.grm 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,143 @@
+%%
+
+(* bugs: no functor, structure, or abstype support *)
+
+%term LONGID of string
+ | TYVAR of string
+ | AND | ASTERISK | BAR | COLON | COMMA | DATATYPE | EOF | EQUALOP
+ | EQTYPE | LBRACE | LPAREN | OF | OP | RBRACE | RPAREN | TYPE | WITHTYPE
+
+%nonterm file of toplevel_typ list
+ | node of toplevel_typ
+ | typBind of toplevel_typ
+ | typBind' of inline_typ bind_typ list
+ | typBind'' of inline_typ bind_typ list
+ | tyvars of (tyvar * tag) vector
+ | tyvar_pc of (tyvar * tag) list
+ | datatypeRhs of toplevel_typ
+ | db of data_typ bind_typ
+ | dbs of data_typ bind_typ list
+ | withtypes of inline_typ bind_typ list
+ | constrs of (string * inline_typ option) list
+ | constr of string * inline_typ option
+ | opcon of string
+ | con of string
+ | longid of string
+ | longidnA of string
+ | id of string
+ | idnA of string
+ | tyvar of tyvar
+ | tycon of string
+ | longtycon of string
+ | ty of inline_typ
+ | ty' of inline_typ
+ | tlabels of (string * inline_typ) list
+ | tlabel of string * inline_typ
+ | ty0_pc of (inline_typ * tag) list
+ | tuple_ty of inline_typ list
+
+%pos unit
+%verbose
+%eop EOF
+%noshift EOF
+%name TML
+%keyword AND DATATYPE EQTYPE OF OP TYPE WITHTYPE
+
+%value LONGID ("bogus")
+%value TYVAR ("'a")
+
+%%
+
+file : ([])
+ | node file (node :: file)
+
+node : DATATYPE datatypeRhs (datatypeRhs)
+ | TYPE typBind (typBind)
+ | EQTYPE typBind (typBind)
+
+(* ==================== Type ============ *)
+
+typBind : typBind' ((Vector.fromList [], Vector.fromList typBind'))
+
+typBind' : tyvars tycon EQUALOP ty typBind''
+ ({ name = tycon, reader = "", writer = "", tyvars = tyvars,
+ typ = ty } :: typBind'')
+
+typBind'' : ([])
+ | AND typBind' (typBind')
+
+tyvars : (Vector.fromList [])
+ | tyvar (Vector.fromList [(tyvar, "")])
+ | LPAREN tyvar_pc RPAREN (Vector.fromList tyvar_pc)
+
+tyvar_pc : tyvar ([(tyvar, "")])
+ | tyvar COMMA tyvar_pc ((tyvar, "") :: tyvar_pc)
+
+(* ==================== DataType ============ *)
+
+datatypeRhs : tyvars tycon EQUALOP DATATYPE longtycon
+ (Vector.fromList [], Vector.fromList
+ [{ name = tycon, reader = "", writer = "", tyvars = tyvars,
+ typ = RECURSIVE (longtycon,
+ Vector.map (fn (x, y) => (TYVAR (x, "", ""), y))
+ tyvars, "")}])
+ | dbs withtypes
+ ((Vector.fromList dbs, Vector.fromList withtypes))
+
+dbs : db ([db])
+ | db AND dbs (db :: dbs)
+
+db : tyvars tycon EQUALOP constrs
+ ({ name = tycon, reader = "", writer = "", tyvars = tyvars,
+ typ = ("", "", Vector.fromList constrs) })
+
+constrs : constr ([constr])
+ | constr BAR constrs (constr :: constrs)
+
+constr : opcon (opcon, NONE)
+ | opcon OF ty (opcon, SOME ty)
+
+opcon : con (con)
+ | OP con (con)
+
+withtypes : ([])
+ | WITHTYPE typBind' (typBind')
+
+(* ==================== Terminals ============ *)
+
+longidnA : LONGID (LONGID)
+longid : longidnA (longidnA)
+ | ASTERISK ("*")
+
+id : longid (longid) (* forbid '.' in name !!! *)
+idnA : longidnA (longidnA) (* forbid '.' in name !!! *)
+
+con : id (id)
+tycon : idnA (idnA)
+longtycon : idnA (idnA)
+
+tyvar : TYVAR (TYVAR)
+
+(* ==================== Types ================ *)
+
+ty : tuple_ty (TUPLE (Vector.fromList tuple_ty))
+ | ty' (ty')
+
+ty' : tyvar (TYVAR (tyvar, "", ""))
+ | LBRACE tlabels RBRACE (RECORD (Vector.fromList tlabels))
+ | LBRACE RBRACE (RECORD (Vector.fromList []))
+ | LPAREN ty0_pc RPAREN longtycon (RECURSIVE (longtycon, Vector.fromList ty0_pc, ""))
+ | LPAREN ty RPAREN (ty)
+ | ty' longtycon (RECURSIVE (longtycon, Vector.fromList [(ty', "")], ""))
+ | longtycon (RECURSIVE (longtycon, Vector.fromList [], ""))
+
+tlabel : id COLON ty (id, ty)
+
+tlabels : tlabel COMMA tlabels (tlabel :: tlabels)
+ | tlabel ([tlabel])
+
+tuple_ty : ty' ASTERISK tuple_ty (ty' :: tuple_ty)
+ | ty' ASTERISK ty' ([ty'1, ty'2])
+
+ty0_pc : ty COMMA ty ([(ty1, ""), (ty2, "")])
+ | ty COMMA ty0_pc ((ty, "") :: ty0_pc)
Added: mltonlib/trunk/ca/terpstra/pickle/tml.lex
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tml.lex 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tml.lex 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,71 @@
+val nix = ((), ())
+fun eof () = Tokens.EOF nix
+
+type svalue = Tokens.svalue
+type ('a, 'b) token = ('a, 'b) Tokens.token
+type lexresult = (svalue, unit) token
+type arg = unit
+type pos = unit
+
+val commentLevel = ref 0
+
+%%
+
+%reject
+%s A;
+%header (functor TMLLexFun (structure Tokens : TML_TOKENS));
+
+alphanum=[A-Za-z'_0-9]*;
+alphanumId=[A-Za-z]{alphanum};
+sym=[-!%&$+/:<=>?@~`^|#*]|"\\";
+symId={sym}+;
+id={alphanumId}|{symId};
+longid={id}("."{id})*;
+ws=("\012"|[\t\ ])*;
+nrws=("\012"|[\t\ ])+;
+cr="\013";
+nl="\010";
+eol=({cr}{nl}|{nl}|{cr});
+num=[0-9]+;
+frac="."{num};
+exp=[eE](~?){num};
+real=(~?)(({num}{frac}?{exp})|({num}{frac}{exp}?));
+hexDigit=[0-9a-fA-F];
+hexnum={hexDigit}+;
+
+%%
+<INITIAL>{ws} => (continue ());
+<INITIAL>{eol} => (continue ());
+<INITIAL>"," => (Tokens.COMMA nix);
+<INITIAL>"{" => (Tokens.LBRACE nix);
+<INITIAL>"}" => (Tokens.RBRACE nix);
+<INITIAL>"(" => (Tokens.LPAREN nix);
+<INITIAL>")" => (Tokens.RPAREN nix);
+<INITIAL>"|" => (Tokens.BAR nix);
+<INITIAL>":" => (Tokens.COLON nix);
+<INITIAL>"=" => (Tokens.EQUALOP nix);
+<INITIAL>"and" => (Tokens.AND nix);
+<INITIAL>"datatype" => (Tokens.DATATYPE nix);
+<INITIAL>"eqtype" => (Tokens.EQTYPE nix);
+<INITIAL>"of" => (Tokens.OF nix);
+<INITIAL>"op" => (Tokens.OP nix);
+<INITIAL>"type" => (Tokens.TYPE nix);
+<INITIAL>"withtype" => (Tokens.WITHTYPE nix);
+<INITIAL>"'"{alphanum}? => (Tokens.TYVAR (yytext, (), ()));
+<INITIAL>{longid} =>
+ (case yytext of
+ "*" => Tokens.ASTERISK nix
+ | _ => Tokens.LONGID (yytext, (), ()));
+<INITIAL>"(*" => (YYBEGIN A
+ ; commentLevel := 1
+ ; continue ());
+<INITIAL>. => (print ("parsing: illegal token\n") ;
+ continue ());
+
+<A>"(*" => (commentLevel := !commentLevel + 1; continue ());
+<A>"*)" => (commentLevel := !commentLevel - 1
+ ; if 0 = !commentLevel then YYBEGIN INITIAL else ()
+ ; continue ());
+<A>. => (continue ());
+<A>{ws} => (continue ());
+<A>{eol} => (continue ());
Added: mltonlib/trunk/ca/terpstra/pickle/tree.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/tree.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/tree.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,173 @@
+signature MAP =
+ sig
+ type k
+ type 'a t
+
+ val empty: 'a t
+
+ val app: (k * 'a -> unit) -> 'a t -> unit
+ val filter: (k * 'a -> bool) -> 'a t -> 'a t
+ val map: (k * 'a -> k * 'b) -> 'a t -> 'b t
+
+ val foldl: ((k * 'a) * 'b -> 'b) -> 'b -> 'a t -> 'b
+ val foldr: ((k * 'a) * 'b -> 'b) -> 'b -> 'a t -> 'b
+
+ val fromList: (k * 'a) list -> 'a t
+ val fromVector: (k * 'a) vector -> 'a t
+
+ val fetch: 'a t -> k -> 'a option
+ val insert: 'a t -> k * 'a -> 'a t
+
+ (* put smaller set on the right *)
+ val union: 'a t * 'a t -> 'a t
+ val intersection: 'a t * 'a t -> 'a t
+ val difference: 'a t * 'a t -> 'a t
+ end
+
+signature SET =
+ sig
+ type k
+ type t
+
+ val empty: t
+
+ val app: (k -> unit) -> t -> unit
+ val filter: (k -> bool) -> t -> t
+ val map: (k -> k ) -> t -> t
+
+ val foldl: (k * 'a -> 'a) -> 'a -> t -> 'a
+ val foldr: (k * 'a -> 'a) -> 'a -> t -> 'a
+
+ val fromList: k list -> t
+ val fromVector: k vector -> t
+
+ val member: t -> k -> bool
+ val insert: t -> k -> t
+
+ (* put smaller set on the right *)
+ val union: t * t -> t
+ val intersection: t * t -> t
+ val difference: t * t -> t
+ end
+
+signature TREE_ORDER =
+ sig
+ type 'a member
+ val order: 'a member * 'a member -> order
+ end
+
+functor Tree(O : TREE_ORDER) =
+ struct
+ open O
+ datatype colour = Red | Black
+ datatype 'a tree = Node of colour * 'a tree * 'a member * 'a tree | Leaf
+
+ val empty = Leaf
+
+ fun app f Leaf = ()
+ | app f (Node (_, l, v, r)) =
+ (app f l; f v; app f r)
+
+ fun map f Leaf = Leaf
+ | map f (Node (c, l, v, r)) =
+ Node (c, map f l, f v, map f r)
+
+ fun foldl f b Leaf = b
+ | foldl f b (Node (c, l, v, r)) =
+ foldl f (f (v, foldl f b l)) r
+
+ fun foldr f b Leaf = b
+ | foldr f b (Node (c, l, v, r)) =
+ foldr f (f (v, foldr f b r)) l
+
+ fun member Leaf _ = false
+ | member (Node (_, l, v, r)) x =
+ case order (x, v) of
+ LESS => member l x
+ | GREATER => member r x
+ | EQUAL => true
+
+ fun balance x = case x of
+ (Black, Node (Red, Node (Red, a, x, b), y, c), z, d) =>
+ Node (Red, Node (Black, a, x, b), y, Node (Black, c, z, d))
+ | (Black, Node (Red, a, x, Node (Red, b, y, c)), z, d) =>
+ Node (Red, Node (Black, a, x, b), y, Node (Black, c, z, d))
+ | (Black, a, x, Node (Red, Node (Red, b, y, c), z, d)) =>
+ Node (Red, Node (Black, a, x, b), y, Node (Black, c, z, d))
+ | (Black, a, x, Node (Red, b, y, Node (Red, c, z, d))) =>
+ Node (Red, Node (Black, a, x, b), y, Node (Black, c, z, d))
+ | (a, b, c, d) =>
+ Node (a, b, c, d)
+
+ fun insert t x =
+ let
+ fun ins Leaf = Node (Red, Leaf, x, Leaf)
+ | ins (Node (c, a, y, b)) =
+ case order (x, y) of
+ LESS => balance (c, ins a, y, b)
+ | GREATER => balance (c, a, y, ins b)
+ | EQUAL => Node (c, a, x, b)
+ in
+ case ins t of
+ Node (_, a, y, b) => Node (Black, a, y, b)
+ | Leaf => Leaf
+ end
+
+ fun fromList l =
+ List.foldl (fn (v, t) => insert t v) empty l
+ fun fromVector v =
+ Vector.foldl (fn (v, t) => insert t v) empty v
+
+ fun filter f t =
+ foldl (fn (v, t) => if f v then insert t v else t) empty t
+
+ fun union (x, y) =
+ foldl (fn (v, t) => insert t v) x y
+ fun intersection (x, y) =
+ filter (member x) y
+ fun difference (x, y) =
+ filter (not o member y) x
+ end
+
+signature KEY_ORDER =
+ sig
+ type k
+ val order: k * k -> order
+ end
+
+functor Set(O : KEY_ORDER) :> SET where type k = O.k =
+ struct
+ structure TO =
+ struct
+ type 'a member = O.k
+ val order = O.order
+ end
+
+ structure Tree = Tree(TO)
+ open Tree
+
+ type k = O.k
+ type t = unit tree
+ end
+
+functor Map(O : KEY_ORDER) :> MAP where type k = O.k =
+ struct
+ structure TO =
+ struct
+ type 'a member = O.k * 'a
+ fun order ((x, _), (y, _)) = O.order (x, y)
+ end
+
+ structure Tree = Tree(TO)
+ open Tree
+
+ type k = O.k
+ type 'a t = 'a tree
+
+ fun fetch Leaf _ = NONE
+ | fetch (Node (_, l, (k, v), r)) x =
+ case O.order (x, k) of
+ LESS => fetch l x
+ | GREATER => fetch r x
+ | EQUAL => SOME v
+ end
Added: mltonlib/trunk/ca/terpstra/pickle/type.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/pickle/type.sml 2006-12-19 02:56:05 UTC (rev 4983)
+++ mltonlib/trunk/ca/terpstra/pickle/type.sml 2006-12-19 02:56:32 UTC (rev 4984)
@@ -0,0 +1,41 @@
+fun dtype ((data, bind), (l, scope)) =
+ let
+ val withscope = Map.union (scope, defd data)
+ val datascope = Map.union (withscope, defd bind)
+
+ fun dump scope =
+ let
+ fun record (n, typ) l = l && n && ": " ++ inline typ
+ and tyvars v l =
+ if Vector.length v = 0 then l else
+ l && "(" ++ sfoldl (inline o #1, ", ", v) && ") "
+ and invoke n l =
+ case Map.fetch scope n of
+ NONE => l && "Arg." && n
+ | SOME _ => l && n
+ and inline node l =
+ case node of
+ (RECORD v) => l && "{ " ++ sfoldl (record, ", ", v) && " }"
+ | (RECURSIVE (n, v, _)) => l ++ tyvars v ++ invoke n
+ | (TUPLE v) => l ++ sfoldl (inline, " * ", v)
+ | (TYVAR (tyvar, _, _)) => l && tyvar
+ in
+ inline
+ end
+
+ fun withtyp (i, { name, reader=_, writer=_, tyvars, typ }) l =
+ l && (if i = 0 then "type " else "and ")
+ ++ tuple (#1, tyvars) && name && " = " ++ dump withscope typ && "\n"
+
+ fun const (n, NONE) l = l && n && "\n"
+ | const (n, SOME typ) l = l && n && " of " ++ dump datascope typ && "\n"
+ fun datatyp (i, { name, reader=_, writer=_, tyvars, typ = (_, _, v) }) l =
+ l && (if i = 0 then " datatype " else " and ")
+ ++ tuple (#1, tyvars) && name && " = " ++ sfoldl (const, "\t| ", v)
+ in
+ (l ++ foldli (datatyp, data)
+ && (if Vector.length data <> 0 andalso
+ Vector.length bind <> 0 then "with" else "")
+ ++ foldli (withtyp, bind),
+ datascope)
+ end
|
