[MLton-commit] r5598
Vesa Karvonen
vesak at mlton.org
Thu Jun 7 11:51:41 PDT 2007
Some generic values.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/
A mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,101 @@
+(* 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.
+ *)
+
+structure Dummy :> DUMMY_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum
+ infix 7 *`
+ infix 6 +`
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure Lifted = LiftGeneric
+ (structure Index = struct
+ type 'a t = 'a Option.t
+ type 'a s = 'a t
+ type ('a, 'k) p = 'a t
+ end
+
+ fun iso b = flip Option.map b o Iso.from
+
+ fun a *` b = case a & b of
+ SOME a & SOME b => SOME (a & b)
+ | _ => NONE
+
+ fun a +` b = case a of
+ SOME a => SOME (INL a)
+ | NONE => Option.map INR b
+
+ fun Y ? = Tie.pure (const (NONE, id)) ?
+
+ local
+ val e = Fail "Dummy.-->"
+ in
+ fun _ --> _ = SOME (raising e)
+ end
+
+ val exn = SOME Empty
+ fun regExn _ _ = ()
+
+ fun array _ = SOME (Array.tabulate (0, undefined))
+ fun refc ? = Option.map ref ?
+
+ fun vector _ = SOME (Vector.tabulate (0, undefined))
+
+ val largeInt : LargeInt.t Index.t = SOME 0
+ val largeReal : LargeReal.t Index.t = SOME 0.0
+ val largeWord : LargeWord.t Index.t = SOME 0w0
+
+ fun list _ = SOME []
+
+ val bool = SOME false
+ val char = SOME #"\000"
+ val int = SOME 0
+ val real = SOME 0.0
+ val string = SOME ""
+ val unit = SOME ()
+ val word = SOME 0w0
+
+ val word8 : Word8.t Index.t = SOME 0w0
+ (* val word16 : Word16.t Index.t = SOME 0w0 *)
+ val word32 : Word32.t Index.t = SOME 0w0
+ val word64 : Word64.t Index.t = SOME 0w0
+
+ (* Trivialities *)
+
+ val isoProduct = iso
+ val isoSum = iso
+
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id)
+
+ open Lifted
+
+ structure Dummy = Index
+ exception Dummy
+
+ fun dummy (vo, _) =
+ case vo of
+ SOME v => v
+ | NONE => raise Dummy
+
+ fun noDummy (_, x) = (NONE, x)
+end
+
+functor WithDummy (Outer : EXT_GENERIC) :> DUMMY_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Outer and Inner = Dummy)
+ open Dummy Joined
+ structure Dummy = Index
+ val dummy = fn ? => dummy (Outer.Index.getT ?)
+ val noDummy = fn ? => Outer.Index.mapT noDummy ?
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,100 @@
+(* 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.
+ *)
+
+structure Eq :> EQ_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum UnPr
+ infix 7 *`
+ infix 6 +`
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure Lifted = LiftGeneric
+ (structure Index = struct
+ type 'a t = 'a BinPr.t
+ type 'a s = 'a t
+ type ('a, 'k) p = 'a t
+ end
+
+ fun iso b (a2b, _) = b o Pair.map (Sq.mk a2b)
+
+ val op *` = Product.equal
+ val op +` = Sum.equal
+
+ val Y = Tie.function
+
+ local
+ val e = Fail "Eq.--> not supported"
+ in
+ fun _ --> _ = raising e
+ end
+
+ val exn : Exn.t Index.t Ref.t = ref GenericsUtil.failExnSq
+ fun regExn t (_, prj) =
+ Ref.modify (fn exn =>
+ fn (l, r) =>
+ case prj l & prj r of
+ SOME l & SOME r => t (l, r)
+ | SOME _ & NONE => false
+ | NONE & SOME _ => false
+ | NONE & NONE => exn (l, r)) exn
+ val exn = fn ? => !exn ?
+
+ fun array _ = op =
+ fun refc _ = op =
+
+ val list = ListPair.allEq
+
+ fun vector eq = iso (list eq) Vector.isoList (* XXX can be optimized *)
+
+ val bool = op =
+ val char = op =
+ val int = op =
+ val real = Real.==
+ val string = op =
+ val unit = op =
+ val word = op =
+
+ val largeInt = op =
+ val largeReal = LargeReal.==
+ val largeWord = op =
+
+ val word8 = op =
+ (* val word16 = op = *)
+ val word32 = op =
+ val word64 = op =
+
+ (* Trivialities *)
+
+ val isoProduct = iso
+ val isoSum = iso
+
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id)
+
+ open Lifted
+
+ structure Eq = Index
+
+ val eq = Pair.fst
+ fun notEq (eq, _) = negate eq
+end
+
+functor WithEq (Outer : EXT_GENERIC) :> EQ_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Outer and Inner = Eq)
+ open Eq Joined
+ structure Eq = Index
+ fun mk f = f o Outer.Index.getT
+ val eq = fn ? => mk eq ?
+ val notEq = fn ? => mk notEq ?
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,102 @@
+(* 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.
+ *)
+
+structure Ord :> ORD_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum UnPr
+ infix 7 *`
+ infix 6 +`
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure Lifted = LiftGeneric
+ (structure Index = struct
+ type 'a t = 'a Cmp.t
+ type 'a s = 'a t
+ type ('a, 'k) p = 'a t
+ end
+
+ fun inj b a2b = b o Pair.map (Sq.mk a2b)
+ fun iso b = inj b o Iso.to
+
+ val op *` = Product.collate
+ val op +` = Sum.collate
+
+ val Y = Tie.function
+
+ local
+ val e = Fail "Compare.--> not supported"
+ in
+ fun _ --> _ = raising e
+ end
+
+ (* XXX It is also possible to implement exn so that compare provides
+ * a reasonable answer as long as at least one of the exception
+ * variants (involved in a comparison) has been registered.
+ *)
+ val exn : Exn.t Index.t Ref.t = ref GenericsUtil.failExnSq
+ fun regExn t (_, prj) =
+ Ref.modify (fn exn =>
+ fn (l, r) =>
+ case prj l & prj r of
+ SOME l & SOME r => t (l, r)
+ | SOME _ & NONE => GREATER
+ | NONE & SOME _ => LESS
+ | NONE & NONE => exn (l, r)) exn
+ val exn = fn ? => !exn ?
+
+ val array = Array.collate
+ fun refc ? = inj ? !
+
+ val vector = Vector.collate
+
+ val list = List.collate
+
+ val unit = fn ((), ()) => EQUAL
+ val bool = Bool.compare
+ val char = Char.compare
+ val int = Int.compare
+ val real = Real.compare
+ val string = String.compare
+ val word = Word.compare
+
+ val largeInt = LargeInt.compare
+ val largeReal = LargeReal.compare
+ val largeWord = LargeWord.compare
+
+ val word8 = Word8.compare
+ (* val word16 = Word16.compare *)
+ val word32 = Word32.compare
+ val word64 = Word64.compare
+
+ (* Trivialities *)
+
+ val isoProduct = iso
+ val isoSum = iso
+
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id)
+
+ open Lifted
+
+ structure Ord = Index
+
+ val compare = Pair.fst
+end
+
+functor WithOrd (Outer : EXT_GENERIC) :> ORD_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Outer and Inner = Ord)
+ open Ord Joined
+ structure Ord = Index
+ val compare = fn ? => compare (Outer.Index.getT ?)
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,206 @@
+(* 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.
+ *)
+
+(* XXX show sharing *)
+(* XXX pretty printing could use some tuning *)
+(* XXX parameters for pretty printing? *)
+(* XXX parameters for depth, length, etc... for showing only partial data *)
+
+structure Show :> SHOW_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum UnPr
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >|
+ infixr 2 |<
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure Lifted = LiftGeneric
+ (local
+ open Prettier
+ type u = Bool.t * t
+ fun atomic doc = (true, doc)
+ fun nonAtomic doc = (false, doc)
+ val uop : t UnOp.t -> u UnOp.t = id <\ Pair.map
+ val bop : t BinOp.t -> u BinOp.t =
+ fn f => nonAtomic o f o Pair.map (Sq.mk Pair.snd)
+ in
+ type u = u
+
+ val parens = (1, (lparen, rparen))
+ val hashParens = (2, (txt "#(", rparen))
+ val braces = (1, (lbrace, rbrace))
+ val brackets = (1, (lbracket, rbracket))
+ val hashBrackets = (2, (txt "#[", rbracket))
+
+ val comma = atomic comma
+ val equals = atomic equals
+
+ val txt = atomic o txt
+ fun surround (n, p) = atomic o group o nest n o enclose p o Pair.snd
+ fun atomize (d as (a, _)) = if a then d else surround parens d
+ val punctuate = fn (_, s) => punctuate s o List.map Pair.snd
+ val fill = fn ? => nonAtomic (vsep ?)
+ val group = uop group
+ val nest = uop o nest
+ val op <^> = fn ((al, dl), (ar, dr)) => (al andalso ar, dl <^> dr)
+ val op <$> = bop op <$>
+ val op </> = bop op </>
+ end
+
+ local
+ open Generics
+ in
+ val C = C
+ val l2s = Label.toString
+ val c2s = Con.toString
+ end
+
+ structure Index = struct
+ type 'a t = exn list * 'a -> u
+ type 'a s = 'a t
+ type ('a, 'k) p = 'a t
+ end
+
+ fun inj b a2b = b o Pair.map (id, a2b)
+ fun iso b = inj b o Iso.to
+ val isoProduct = iso
+ val isoSum = iso
+
+ fun (l *` r) (env, a & b) = l (env, a) <^> comma <$> r (env, b)
+
+ val T = id
+ fun R label = let
+ val txtLabel = txt (l2s label)
+ fun fmt t ? = group (nest 1 (txtLabel </> equals </> t ?))
+ in
+ fmt
+ end
+
+ fun tuple t = surround parens o t
+ fun record t = surround braces o t
+
+ fun l +` r = fn (env, INL a) => l (env, a)
+ | (env, INR b) => r (env, b)
+
+ fun C0 ctor = const (txt (c2s ctor))
+ fun C1 ctor = let
+ val txtCtor = txt (c2s ctor)
+ in
+ fn t => fn ? => nest 1 (group (txtCtor <$> atomize (t ?)))
+ end
+
+ val data = id
+
+ val Y = Tie.function
+
+ val exn : Exn.t Index.t ref =
+ ref (txt o "#" <\ op ^ o General.exnName o #2)
+ fun regExn t (_, prj) =
+ Ref.modify (fn exn => fn (env, e) =>
+ case prj e of
+ NONE => exn (env, e)
+ | SOME x => t (env, x)) exn
+ val exn = fn ? => !exn ?
+
+ val txtAs = txt "as"
+ fun cyclic t = let
+ exception E of ''a * bool ref
+ in
+ fn (env, v : ''a) => let
+ val idx = Int.toString o length
+ fun lp (E (v', c)::env) =
+ if v' <> v then
+ lp env
+ else
+ (c := false ; txt ("#"^idx env))
+ | lp (_::env) = lp env
+ | lp [] = let
+ val c = ref true
+ val r = t (E (v, c)::env, v)
+ in
+ if !c then
+ r
+ else
+ txt ("#"^idx env) </> txtAs </> r
+ end
+ in
+ lp env
+ end
+ end
+ fun aggregate style toL t (env, a) =
+ surround style o fill o punctuate comma o List.map (curry t env) |< toL a
+
+ val ctorRef = C "ref"
+ fun refc ? = cyclic o flip inj ! |< C1 ctorRef ?
+ fun array ? = cyclic |< aggregate hashParens Array.toList ?
+
+ fun vector ? = aggregate hashBrackets Vector.toList ?
+
+ fun list ? = aggregate brackets id ?
+
+ val txtFn = txt "#fn"
+ fun _ --> _ = const txtFn
+
+ local
+ open Prettier
+ val toLit = txt o String.toString
+ val nlbs = txt "\\n\\"
+ in
+ fun string (_, s) =
+ (true,
+ group o dquotes |< choice
+ {wide = toLit s,
+ narrow = lazy (fn () =>
+ List.foldl1
+ (fn (x, s) =>
+ s <^> nlbs <$> backslash <^> x)
+ (List.map toLit
+ (String.fields
+ (#"\n" <\ op =) s)))})
+ end
+
+ fun mk toS : 'a Index.t = txt o toS o Pair.snd
+ fun enc l r toS x = concat [l, toS x, r]
+ fun mkWord toString = mk ("0wx" <\ op ^ o toString)
+
+ val bool = mk Bool.toString
+ val char = mk (enc "#\"" "\"" Char.toString)
+ val int = mk Int.toString
+ val real = mk Real.toString
+ val unit = mk (Thunk.mk "()")
+ val word = mkWord Word.toString
+
+ val largeInt = mk LargeInt.toString
+ val largeReal = mk LargeReal.toString
+ val largeWord = mkWord LargeWord.toString
+
+ val word8 = mkWord Word8.toString
+ (* val word16 = mkWord Word16.toString *)
+ val word32 = mkWord Word32.toString
+ val word64 = mkWord Word64.toString)
+
+ open Lifted
+
+ structure Show = Index
+
+ fun layout (t, _) x = Pair.snd (t ([], x))
+ fun show m t = Prettier.pretty m o layout t
+end
+
+functor WithShow (Outer : EXT_GENERIC) :> SHOW_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Outer and Inner = Show)
+ open Joined
+ fun layout ? = Show.layout (Outer.Index.getT ?)
+ fun show m = Show.show m o Outer.Index.getT
+ structure Show = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,165 @@
+(* 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.
+ *)
+
+structure TypeInfo :> TYPE_INFO_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum UnPr
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >| andAlso
+ infixr 2 |<
+ infix 1 orElse
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ datatype u =
+ IN of {alts : Int.t,
+ base : Bool.t,
+ exn : Bool.t,
+ pure : Bool.t,
+ recs : Int.t List.t}
+
+ fun revMerge (xs, ys) = let
+ fun lp ([], ys, zs) = (ys, zs)
+ | lp (xs, [], zs) = (xs, zs)
+ | lp (x::xs, y::ys, zs) =
+ case Int.compare (x, y) of
+ LESS => lp (xs, y::ys, x::zs)
+ | EQUAL => lp (xs, ys, x::zs)
+ | GREATER => lp (x::xs, ys, y::zs)
+ in
+ lp (xs, ys, [])
+ end
+
+ val merge = List.revAppend o Pair.swap o revMerge
+
+ fun remove x ys = let
+ fun lp (zs, []) = (zs, [])
+ | lp (zs, y::ys) =
+ case Int.compare (x, y) of
+ LESS => (zs, y::ys)
+ | EQUAL => (zs, ys)
+ | GREATER => lp (y::zs, ys)
+ in
+ List.revAppend (lp ([], ys))
+ end
+
+ structure Lifted = LiftGeneric
+ (structure Index = struct
+ type 'a t = u
+ type 'a s = u
+ type ('a, 'k) p = u
+ end
+
+ val base = IN {alts = 1, base = true, exn = false, pure = true, recs = []}
+ fun pure (IN {exn, recs, ...}) =
+ IN {alts = 1, base = true, exn = exn, pure = true, recs = recs}
+
+ fun iso (IN {base, exn, pure, recs, ...}) =
+ const (IN {alts = 1, base = base, exn = exn, pure = pure, recs = recs})
+
+ fun (IN {base = bl, exn = hl, recs = rl, ...}) *`
+ (IN {base = br, exn = hr, recs = rr, ...}) =
+ IN {alts = 1, base = bl andalso br, exn = hl orelse hr, pure = true,
+ recs = merge (rl, rr)}
+
+ fun (IN {alts = al, base = bl, exn = hl, recs = rl, ...}) +`
+ (IN {alts = ar, base = br, exn = hr, recs = rr, ...}) =
+ IN {alts = al + ar, base = bl orelse br, exn = hl orelse hr, pure = true,
+ recs = merge (rl, rr)}
+
+ val unit = base
+
+ local
+ val id = ref 0
+ in
+ fun Y ? =
+ Tie.pure
+ (fn () => let
+ val this = !id before id := !id + 1
+ in
+ (IN {alts = 1, base = false, exn = false, pure = true, recs = [this]},
+ fn IN {alts, base, exn, pure, recs} =>
+ IN {alts = alts, base = base, exn = exn, pure = pure,
+ recs = remove this recs})
+ end) ?
+ end
+
+ fun _ --> _ = base
+
+ val exn = IN {alts = 1, base = true, exn = true, pure = true, recs = []}
+ fun regExn _ _ = ()
+
+ fun array (IN {exn, recs, ...}) =
+ IN {alts = 1, base = true, exn = exn, pure = false, recs = recs}
+ fun refc (IN {base, exn, recs, ...}) =
+ IN {alts = 1, base = base, exn = exn, pure = false, recs = recs}
+
+ val vector = pure
+
+ val largeInt = base
+ val largeReal = base
+ val largeWord = base
+
+ val list = pure
+
+ val bool = base
+ val char = base
+ val int = base
+ val real = base
+ val string = base
+ val word = base
+
+ val word8 = base
+ val word16 = base
+ val word32 = base
+ val word64 = base
+
+ (* Trivialities *)
+
+ val isoProduct = iso
+ val isoSum = iso
+
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id)
+
+ open Lifted
+
+ structure TypeInfo = Index
+
+ fun out (IN t, _) = t
+
+ fun hasBaseCase ? = (#base o out) ?
+ fun hasExn ? = (#exn o out) ?
+ fun hasRecData ? = (not o null o #recs o out) ?
+ fun isRefOrArray ? = (not o #pure o out) ?
+ fun numConsecutiveAlts ? = (#alts o out) ?
+ fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
+end
+
+functor WithTypeInfo (Outer : EXT_GENERIC) :> TYPE_INFO_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Outer and Inner = TypeInfo)
+ open TypeInfo Joined
+ structure TypeInfo = Index
+ fun mk f = f o Outer.Index.getT
+ val canBeCyclic = fn ? => mk canBeCyclic ?
+ val hasBaseCase = fn ? => mk hasBaseCase ?
+ val hasExn = fn ? => mk hasExn ?
+ val hasRecData = fn ? => mk hasRecData ?
+ val isRefOrArray = fn ? => mk isRefOrArray ?
+ val numConsecutiveAlts = fn ? => mk numConsecutiveAlts ?
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,39 @@
+(* 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.
+ *)
+
+(**
+ * A signature for a type-indexed family of dummy values. In SML, dummy
+ * values are needed for things such as computing fixpoints and building
+ * cyclic values.
+ *
+ * This type-indexed function is unlikely to be directly useful in
+ * application programs and is more likely to be used internally in the
+ * implementation of some other type-indexed functions (e.g. pickling).
+ *)
+signature DUMMY = sig
+ structure Dummy : EXT_GENERIC_INDEX
+
+ exception Dummy
+ (**
+ * This is raised when trying to extract the dummy value in case of
+ * unfounded recursion or an abstract type that has not been given a
+ * dummy value.
+ *)
+
+ val dummy : ('a, 'x) Dummy.t -> 'a
+ (** Extracts the dummy value or raises {Dummy}. *)
+
+ val noDummy : ('a, 'x) Dummy.t UnOp.t
+ (**
+ * Removes the dummy value from the given type-index. This can be used
+ * for encoding abstract types that can not be given dummy values.
+ *)
+end
+
+signature DUMMY_GENERIC = sig
+ include DUMMY EXT_GENERIC
+ sharing Dummy = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithDummy (Outer : EXT_GENERIC) : DUMMY_GENERIC = WithDummy (Ext)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,29 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a type-indexed equality relation. For equality types the
+ * semantics is the same as SML's built-in equality. User defined types,
+ * exceptions, and reals are given a natural, structural, semantics of
+ * equality. Functions, obviously, can't be supported.
+ *)
+signature EQ = sig
+ structure Eq : EXT_GENERIC_INDEX
+
+ val eq : ('a, 'x) Eq.t -> 'a BinPr.t
+ (**
+ * Extracs the equality relation. Note that the type parameter {'a}
+ * isn't an equality type variable.
+ *)
+
+ val notEq : ('a, 'x) Eq.t -> 'a BinPr.t
+ (** {notEq t = not o eq t} *)
+end
+
+signature EQ_GENERIC = sig
+ include EQ EXT_GENERIC
+ sharing Eq = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithEq (Outer : EXT_GENERIC) : EQ_GENERIC = WithEq (Outer)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,30 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a type-indexed family of compare functions. The idea is
+ * that the compare functions just implement some arbitrary logical
+ * ordering that you need for things such as search trees.
+ *
+ * Note that comparison of functions is impossible and fails at run-time.
+ * Comparison of exceptions only works when both exception constructors
+ * involved in a comparison have been registered with {regExn}. Also,
+ * comparison of arrays and references does not coincide with SML's notion
+ * of equality. More precisely, for an implementation of the {ORD}
+ * signature, two arrays (or refs) {a} and {b} may compare {EQUAL}, but it
+ * is not necessarily the case that {a=b} evaluates to {true}.
+ *)
+signature ORD = sig
+ structure Ord : EXT_GENERIC_INDEX
+
+ val compare : ('a, 'x) Ord.t -> 'a Cmp.t
+ (** Extracts the compare function. *)
+end
+
+signature ORD_GENERIC = sig
+ include ORD EXT_GENERIC
+ sharing Ord = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithOrd (Outer : EXT_GENERIC) : ORD_GENERIC = WithOrd (Outer)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,25 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a type-indexed function for pretty printing values of
+ * arbitrary SML datatypes. See [http://mlton.org/TypeIndexedValues]
+ * for further discussion.
+ *)
+signature SHOW = sig
+ structure Show : EXT_GENERIC_INDEX
+
+ val layout : ('a, 'x) Show.t -> 'a -> Prettier.t
+ (** Extracts the prettifying function. *)
+
+ val show : Int.t Option.t -> ('a, 'x) Show.t -> 'a -> String.t
+ (** {show m t = Prettier.pretty m o layout t} *)
+end
+
+signature SHOW_GENERIC = sig
+ include SHOW EXT_GENERIC
+ sharing Show = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithShow (Outer : EXT_GENERIC) : SHOW_GENERIC = WithShow (Outer)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-06-07 18:51:39 UTC (rev 5598)
@@ -0,0 +1,59 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a type-indexed family of type properties.
+ *
+ * These type properties can be useful for both optimizations and for
+ * ensuring correctness. As an optimization one could, for example,
+ * determine whether one needs to handle cyclic values (which can be
+ * costly) or not. As a correctness issue, one can avoid generating
+ * infinite data structures or avoid performing non-terminating operations
+ * on infinite data structures.
+ *
+ * This type-indexed function is unlikely to be directly useful in
+ * application programs and is more likely to be used internally in the
+ * implementation of some other type-indexed functions (e.g. pickling).
+ *)
+signature TYPE_INFO = sig
+ structure TypeInfo : EXT_GENERIC_INDEX
+
+ val canBeCyclic : ('a, 'x) TypeInfo.t UnPr.t
+ (**
+ * Returns true iff {'a} is of the form {'b ref} or {'b array} and
+ * it can not be ruled out that values of the type can form cycles.
+ *
+ * Note: Functions are not considered to form cycles.
+ *)
+
+ val hasBaseCase : ('a, 'x) TypeInfo.t UnPr.t
+ (** Returns true iff the type {'a} has a non-recursive variant. *)
+
+ val hasExn : ('a, 'x) TypeInfo.t UnPr.t
+ (** Returns true iff the type {'a} contains the type {exn}. *)
+
+ val hasRecData : ('a, 'x) TypeInfo.t UnPr.t
+ (**
+ * Returns true iff the type {'a} contains recursive references to
+ * datatypes.
+ *)
+
+ val isRefOrArray : ('a, 'x) TypeInfo.t UnPr.t
+ (**
+ * Returns true iff the type {'a} is of the form {'b array} or of
+ * the form {'b ref}.
+ *)
+
+ val numConsecutiveAlts : ('a, 'x) TypeInfo.t -> Int.t
+ (**
+ * Number of consecutive alternatives.
+ *)
+end
+
+signature TYPE_INFO_GENERIC = sig
+ include TYPE_INFO EXT_GENERIC
+ sharing TypeInfo = Index
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sml 2007-06-07 16:41:44 UTC (rev 5597)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sml 2007-06-07 18:51:39 UTC (rev 5598)
@@ -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.
+ *)
+
+functor WithTypeInfo (Outer : EXT_GENERIC) : TYPE_INFO_GENERIC =
+ WithTypeInfo (Outer)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list