[MLton-commit] r6033
Vesa Karvonen
vesak at mlton.org
Wed Sep 19 03:22:50 PDT 2007
Added Rep-suffix to all type representation substructures. The motivation
for this is that not multiple generics have "additional" combinators and
definitions that should really be in some substructure. A reasonable
convention then is to name the type representation substructure with a
suffix and the substructure for the additional defs after the name of the
generic.
Also implemented support for infix constructor in Pretty. Infix products
are now pretty printed in infix.
Plus some minor edits here and there.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/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/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/some.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -6,17 +6,21 @@
structure Generic :> sig
include GENERIC_EXTRA
- include ARBITRARY sharing Open.Rep = Arbitrary
- include DATA_REC_INFO sharing Open.Rep = DataRecInfo
- include EQ sharing Open.Rep = Eq
- include HASH sharing Open.Rep = Hash
- include ORD sharing Open.Rep = Ord
- include PICKLE sharing Open.Rep = Pickle
- include PRETTY sharing Open.Rep = Pretty
- include SOME sharing Open.Rep = Some
- include TYPE_HASH sharing Open.Rep = TypeHash
- include TYPE_INFO sharing Open.Rep = TypeInfo
+ include ARBITRARY sharing Open.Rep = ArbitraryRep
+ include DATA_REC_INFO sharing Open.Rep = DataRecInfoRep
+ include EQ sharing Open.Rep = EqRep
+ include HASH sharing Open.Rep = HashRep
+ include ORD sharing Open.Rep = OrdRep
+ include PICKLE sharing Open.Rep = PickleRep
+ include PRETTY sharing Open.Rep = PrettyRep
+ include SOME sharing Open.Rep = SomeRep
+ include TYPE_HASH sharing Open.Rep = TypeHashRep
+ include TYPE_INFO sharing Open.Rep = TypeInfoRep
end = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
+
structure Open = RootGeneric
(* Add generics not depending on any other generic: *)
@@ -29,7 +33,7 @@
structure Open = struct
open TypeHash TypeInfo Open
- structure TypeHash = Rep and TypeInfo = Rep
+ structure TypeHashRep = Rep and TypeInfoRep = Rep
end
structure Open = WithHash (Open) open Open structure Hash=Open
@@ -37,41 +41,41 @@
structure Open = struct
open Hash Open
- structure Hash = Rep
+ structure HashRep = Rep
end
structure Open = WithPretty (Open) open Open
structure Open = struct
open Hash TypeInfo Open
- structure Hash = Rep and TypeInfo = Rep
+ structure HashRep = Rep and TypeInfoRep = Rep
structure RandomGen = RanQD1Gen
end
structure Open = WithArbitrary (Open) open Open
structure Open = struct
open TypeInfo Open
- structure TypeInfo = Rep
+ structure TypeInfoRep = Rep
end
structure Open = WithSome (Open) open Open structure Some=Open
structure Open = struct
open DataRecInfo Eq Hash Some TypeHash TypeInfo Open
- structure DataRecInfo = Rep and Eq = Rep and Hash = Rep and Some = Rep
- and TypeHash = Rep and TypeInfo = Rep
+ structure DataRecInfoRep = Rep and EqRep = Rep and HashRep = Rep
+ and SomeRep = Rep and TypeHashRep = Rep and TypeInfoRep = Rep
end
structure Open = WithPickle (Open) open Open
(* Make type representations equal: *)
- structure Arbitrary = Rep
- structure DataRecInfo = Rep
- structure Eq = Rep
- structure Hash = Rep
- structure Ord = Rep
- structure Pickle = Rep
- structure Pretty = Rep
- structure Some = Rep
- structure TypeHash = Rep
- structure TypeInfo = Rep
+ structure ArbitraryRep = Rep
+ structure DataRecInfoRep = Rep
+ structure EqRep = Rep
+ structure HashRep = Rep
+ structure OrdRep = Rep
+ structure PickleRep = Rep
+ structure PrettyRep = Rep
+ structure SomeRep = Rep
+ structure TypeHashRep = Rep
+ structure TypeInfoRep = Rep
(* Close the combination for use: *)
structure Generic = struct
@@ -82,4 +86,14 @@
(* Add extra type representation constructors: *)
structure Extra = WithExtra (Generic) open Extra
+
+ (* Pretty print products in infix: *)
+ local
+ val et = C "&"
+ in
+ fun op &` ab =
+ iso (data (Pretty.infixL 0 et ab
+ (C1 et (tuple2 ab))))
+ (fn op & ? => ?, op &)
+ end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -62,17 +62,17 @@
IN {gen = xsGen, cog = xsCog}
end
- structure Arbitrary = LayerRep
+ structure ArbitraryRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
- open Arbitrary.This
+ open ArbitraryRep.This
fun arbitrary ? = #gen (out (getT ?))
fun withGen gen = mapT (fn IN {cog, ...} => IN {gen = gen, cog = cog})
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Arbitrary
+ (structure Outer = Arg and Result = ArbitraryRep
fun iso aT = iso' (getT aT)
fun isoProduct aP = iso' (getP aP)
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-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -34,7 +34,7 @@
fun mutable (INT {exn, recs, ...}) =
INT {exn = exn, pure = false, recs = recs}
- structure DataRecInfo = LayerRep
+ structure DataRecInfoRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
type 'a t = t
@@ -42,7 +42,7 @@
type ('a, 'k) p = p
end)
- open DataRecInfo.This
+ open DataRecInfoRep.This
fun outT (INT r) = r
@@ -53,7 +53,8 @@
(isMutableType andAlso (mayContainExn orElse mayBeRecData)) ?
structure Layered = LayerCases
- (structure Outer=Arg and Result=DataRecInfo and Rep=DataRecInfo.Closed
+ (structure Outer=Arg and Result=DataRecInfoRep
+ and Rep=DataRecInfoRep.Closed
val iso = const
val isoProduct = const
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -10,7 +10,7 @@
infix <-->
(* SML/NJ workaround --> *)
- structure Dyn = struct
+ structure Dynamic = struct
datatype t =
PRODUCT of (t, t) Product.t
| SUM of (t, t) Sum.t
@@ -32,74 +32,77 @@
| WORD8 of Word8.t
| WORD32 of Word32.t
| WORD64 of Word64.t
- exception Dyn
+ exception Dynamic
end
- open Dyn
+ open Dynamic
val op <--> = Iso.<-->
fun isoUnsupported text = (failing text, failing text)
- structure Dynamic = LayerRep
+ structure DynamicRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = ('a, t) Iso.t))
- open Dynamic.This
+ open DynamicRep.This
- fun toDyn t = Iso.to (getT t)
- fun fromDyn t d = SOME (Iso.from (getT t) d) handle Dyn.Dyn => NONE
+ fun toDynamic t = Iso.to (getT t)
+ fun fromDynamic t d =
+ SOME (Iso.from (getT t) d) handle Dynamic.Dynamic => NONE
structure Layered = LayerCases
- (structure Outer = Arg and Result = Dynamic and Rep = Dynamic.Closed
+ (structure Outer=Arg and Result=DynamicRep and Rep=DynamicRep.Closed
fun iso bId aIb = bId <--> aIb
val isoProduct = iso
val isoSum = iso
fun op *` is =
- (PRODUCT, fn PRODUCT ? => ? | _ => raise Dyn) <--> Product.iso is
+ (PRODUCT, fn PRODUCT ? => ? | _ => raise Dynamic) <--> Product.iso is
val T = id
fun R _ = id
val tuple = id
val record = id
- fun op +` is = (SUM, fn SUM ? => ? | _ => raise Dyn) <--> Sum.iso is
- val unit = (fn () => UNIT, fn UNIT => () | _ => raise Dyn)
+ fun op +` is = (SUM, fn SUM ? => ? | _ => raise Dynamic) <--> Sum.iso is
+ val unit = (fn () => UNIT, fn UNIT => () | _ => raise Dynamic)
fun C0 _ = unit
fun C1 _ = id
val data = id
fun Y ? = let open Tie in tuple2 (function, function) end ?
- fun op --> is = (ARROW, fn ARROW ? => ? | _ => raise Dyn) <--> Fn.iso is
+ fun op --> is =
+ (ARROW, fn ARROW ? => ? | _ => raise Dynamic) <--> Fn.iso is
- val exn = (EXN, fn EXN ? => ? | _ => raise Dyn)
+ val exn = (EXN, fn EXN ? => ? | _ => raise Dynamic)
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
+ fun list i = (LIST, fn LIST ? => ? | _ => raise Dynamic) <--> List.iso i
+ fun vector i =
+ (VECTOR, fn VECTOR ? => ? | _ => raise Dynamic) <--> Vector.iso i
- fun array _ = isoUnsupported "Dyn.array unsupported"
- fun refc _ = isoUnsupported "Dyn.refc unsupported"
+ fun array _ = isoUnsupported "Dynamic.array unsupported"
+ fun refc _ = isoUnsupported "Dynamic.refc unsupported"
- val fixedInt = (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Dyn)
- val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dyn)
+ val fixedInt = (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Dynamic)
+ val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dynamic)
- val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dyn)
- val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dyn)
+ val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dynamic)
+ val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dynamic)
- val bool = (BOOL, fn BOOL ? => ? | _ => raise Dyn)
- val char = (CHAR, fn CHAR ? => ? | _ => raise Dyn)
- val int = (INT, fn INT ? => ? | _ => raise Dyn)
- val real = (REAL, fn REAL ? => ? | _ => raise Dyn)
- val string = (STRING, fn STRING ? => ? | _ => raise Dyn)
- val word = (WORD, fn WORD ? => ? | _ => raise Dyn)
+ val bool = (BOOL, fn BOOL ? => ? | _ => raise Dynamic)
+ val char = (CHAR, fn CHAR ? => ? | _ => raise Dynamic)
+ val int = (INT, fn INT ? => ? | _ => raise Dynamic)
+ val real = (REAL, fn REAL ? => ? | _ => raise Dynamic)
+ val string = (STRING, fn STRING ? => ? | _ => raise Dynamic)
+ val word = (WORD, fn WORD ? => ? | _ => raise Dynamic)
- val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dyn)
- val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dyn)
- val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dyn))
+ val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dynamic)
+ val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dynamic)
+ val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic))
open Layered
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -32,18 +32,18 @@
| SOME l & SOME r => t (l, r)
| _ => false) exnHandler
- structure Eq = LayerRep
+ structure EqRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (BinPr))
- open Eq.This
+ open EqRep.This
val eq = getT
fun notEq t = not o eq t
fun withEq eq = mapT (const eq)
structure Layered = LayerCases
- (structure Outer = Arg and Result = Eq and Rep = Eq.Closed
+ (structure Outer = Arg and Result = EqRep and Rep = EqRep.Closed
fun iso b (a2b, _) = BinPr.map a2b b
val isoProduct = iso
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -40,11 +40,11 @@
val exns : (Exn.t * p -> Word.t Option.t) Buffer.t = Buffer.new ()
- structure Hash = LayerRep
+ structure HashRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
- open Hash.This
+ open HashRep.This
val defaultHashParam = {totWidth = 200, maxDepth = 10}
@@ -61,7 +61,7 @@
fun hash t = hashParam t defaultHashParam
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Hash
+ (structure Outer = Arg and Result = HashRep
fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -58,11 +58,11 @@
fun iso' getX bX (a2b, _) (e, bp) = getX bX (e, Sq.map a2b bp)
- structure Ord = LayerRep
+ structure OrdRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
- open Ord.This
+ open OrdRep.This
fun ord t = let
val ord = getT t
@@ -72,7 +72,7 @@
fun withOrd cmp = mapT (const (lift cmp))
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Ord
+ (structure Outer = Arg and Result = OrdRep
fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -469,15 +469,15 @@
wr = Option.map (fn a => O.>> (wr string c, aW a)) o e2a}
end
- structure Pickle = LayerRep
+ structure PickleRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
type 'a t = 'a t and 'a s = 'a s and ('a, 'k) p = 'a t
end)
- open Pickle.This
+ open PickleRep.This
- structure Pickling = struct
+ structure Pickle = struct
exception TypeMismatch
end
@@ -498,7 +498,7 @@
run (ResizableArray.new ())
(rd word32 >>= (fn key' =>
if key' <> key
- then raise Pickling.TypeMismatch
+ then raise Pickle.TypeMismatch
else aR))
end
@@ -512,7 +512,7 @@
Substring.full
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Pickle
+ (structure Outer = Arg and Result = PickleRep
fun iso bT aIb = let
val bP = getT bT
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -41,21 +41,21 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- datatype f = ATOMIC | NONFIX
+ datatype f = ATOMIC | NONFIX | INFIXL of Int.t | INFIXR of Int.t
fun mark f doc = (f, doc)
open Prettier
- fun surround (n, p) = mark ATOMIC o group o nest n o enclose p
- fun atomize (a, d) = if ATOMIC = a then d else parens d
-
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))
+ fun surround (n, p) = nest n o enclose p
+ fun atomize (a, d) = if ATOMIC = a then d else surround parens d
+
structure OptInt = struct
type t = Int.t Option.t
local
@@ -179,16 +179,17 @@
in
if SOME 0 = n
then surround style (d <$> txtDots)
- else lp (OptInt.- (n, SOME 1), d <$> aP (e, a), s)
+ else lp (OptInt.- (n, SOME 1), d <$> group (aP (e, a)), s)
end
open Fmt
in
- if SOME 0 = !maxLength fmt
- then surround style txtDots
- else case getItem (toSlice a)
- of NONE => (ATOMIC, op <^> (#2 style))
- | SOME (a, s) =>
- lp (OptInt.- (!maxLength fmt, SOME 1), aP (e, a), s)
+ (ATOMIC,
+ if SOME 0 = !maxLength fmt
+ then surround style txtDots
+ else case getItem (toSlice a)
+ of NONE => op <^> (#2 style)
+ | SOME (a, s) =>
+ lp (OptInt.- (!maxLength fmt, SOME 1), group (aP (e, a)), s))
end
val intPrefix =
@@ -228,7 +229,7 @@
fun iso' bP = inj bP o Iso.to
- structure Pretty = LayerRep
+ structure PrettyRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
type 'a t = 'a t
@@ -236,22 +237,53 @@
type ('a, 'k) p = 'a p
end)
- open Pretty.This
+ open PrettyRep.This
+ structure Pretty = struct
+ local
+ fun mk con n cmpL cmpR =
+ if n < 0 orelse 9 < n then raise Domain else
+ fn c => case txt (Generics.Con.toString c) of c =>
+ fn (aT, bT) => case getT aT & getT bT of aP & bP =>
+ (mapS o const)
+ (fn (e, (a, b)) => let
+ val (aF, aS) = aP (e, a)
+ val (bF, bS) = bP (e, b)
+ val aS = if cmpL aF
+ then surround parens aS
+ else aS
+ val bS = if cmpR bF
+ then surround parens bS
+ else bS
+ in
+ (con n, aS <$> c </> bS)
+ end)
+ in
+ fun infixL n =
+ mk INFIXL n
+ (fn INFIXL l => l < n | INFIXR r => r <= n | _ => false)
+ (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
+ fun infixR n =
+ mk INFIXR n
+ (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
+ (fn INFIXL l => l <= n | INFIXR r => r < n | _ => false)
+ end
+ end
+
fun fmt t =
case getT t
of p => fn fmt => fn x =>
- #2 (p (E ({map = HashMap.new {eq = HashUniv.eq,
- hash = HashUniv.hash},
- cnt = ref ~1,
- fmt = fmt},
- {maxDepth = Fmt.! Fmt.maxDepth fmt}),
- x))
+ group (#2 (p (E ({map = HashMap.new {eq = HashUniv.eq,
+ hash = HashUniv.hash},
+ cnt = ref ~1,
+ fmt = fmt},
+ {maxDepth = Fmt.! Fmt.maxDepth fmt}),
+ x)))
fun pretty t = fmt t Fmt.default
fun show t = Prettier.render NONE o pretty t
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Pretty
+ (structure Outer = Arg and Result = PrettyRep
fun iso aT = iso' (getT aT)
fun isoProduct aP = iso' (getP aP)
@@ -263,13 +295,13 @@
in
fn (e, a & b) => aP (e, a) <^> comma <$> bP (e, b)
end
- fun T t = #2 o getT t
+ fun T t = group o #2 o getT t
fun R l =
case txt (Generics.Label.toString l)
of l => fn aT => case T aT of aP => fn x =>
group (nest 1 (l </> equals </> aP x))
- fun tuple aP = surround parens o getP aP
- fun record aP = surround braces o getP aP
+ fun tuple aP = mark ATOMIC o surround parens o getP aP
+ fun record aP = mark ATOMIC o surround braces o getP aP
fun aS +` bS = let
val aP = getS aS
@@ -312,7 +344,7 @@
then Substring.substring (s, 0, valOf maxString)
else Substring.full s
in
- mark ATOMIC o group o dquotes |< choice
+ mark ATOMIC o dquotes |< choice
{wide = toLit s <^> suf,
narrow = lazy (fn () =>
List.foldl1
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -12,11 +12,11 @@
fun iso' b (_, b2a) = b2a o b
- structure Some = LayerRep
+ structure SomeRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (Thunk))
- open Some.This
+ open SomeRep.This
exception Nothing of Exn.t
@@ -25,7 +25,7 @@
fun withSome v = mapT (const (const v))
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Some
+ (structure Outer = Arg and Result = SomeRep
fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -14,19 +14,21 @@
in
fun unary c h = h * 0w19 + c
fun binary c (l, r) = l * 0w13 + r * 0w17 + c
- fun text toString =
- String.foldl (fn (c, h) => h * 0w33 + fromInt (ord c)) 0w5381 o
- toString
+ local
+ fun textStep (c, h) = h * 0w33 + fromInt (ord c)
+ in
+ fun text s = String.foldl textStep 0w5381 s
+ end
end
- structure TypeHash = LayerRep
+ structure TypeHashRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = Word32.t))
- val typeHash = TypeHash.This.getT
+ val typeHash = TypeHashRep.This.getT
structure Layered = LayerCases
- (structure Outer = Arg and Result = TypeHash and Rep = TypeHash.Closed
+ (structure Outer=Arg and Result=TypeHashRep and Rep=TypeHashRep.Closed
fun iso ? _ = unary 0wxD00B6B6B ?
fun isoProduct ? _ = unary 0wxC01B56DB ?
@@ -34,14 +36,14 @@
val op *` = binary 0wx00ADB6DB
val T = unary 0wx00B6DB6B
- fun R l = unary (text Generics.Label.toString l)
+ fun R l = unary (text (Generics.Label.toString l))
val tuple = unary 0wx00DB6DB5
val record = unary 0wx01B6DB55
val op +` = binary 0wx02DB6D4D
val unit = 0wx036DB6C5 : Word32.t
- val C0 = text Generics.Con.toString
- fun C1 c = unary (text Generics.Con.toString c)
+ val C0 = text o Generics.Con.toString
+ fun C1 c = unary (text (Generics.Con.toString c))
val data = unary 0wx04DB6D63
val Y = Tie.id (0wx05B6DB51 : Word32.t)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -16,7 +16,7 @@
val base = INT {base = true}
fun pure (INT {...}) = INT {base = true}
- structure TypeInfo = LayerRep
+ structure TypeInfoRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
type 'a t = t
@@ -24,7 +24,7 @@
type ('a, 'k) p = p
end)
- open TypeInfo.This
+ open TypeInfoRep.This
fun outS (INS r) = r
fun outP (INP r) = r
@@ -35,7 +35,7 @@
fun numElems ? = (#elems o outP o getP) ?
structure Layered = LayerCases
- (structure Outer = Arg and Result = TypeInfo and Rep = TypeInfo.Closed
+ (structure Outer=Arg and Result=TypeInfoRep and Rep=TypeInfoRep.Closed
val iso = const
val isoProduct = const
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/closed-cases.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -54,7 +54,7 @@
(** == Support for Datatypes == *)
- val +` : 'a Rep.s * 'b Rep.s -> (('a, 'b) Sum.t) Rep.s
+ val +` : 'a Rep.s * 'b Rep.s -> ('a, 'b) Sum.t Rep.s
(**
* Given representations for variants of type {'a} and {'b}, returns a
* representation for the sum {('a, 'b) Sum.t}.
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -11,25 +11,25 @@
* Koen Claessen and John Hughes.
*)
signature ARBITRARY = sig
- structure Arbitrary : OPEN_REP
+ structure ArbitraryRep : OPEN_REP
structure RandomGen : RANDOM_GEN
(** The underlying random value generator. *)
- val arbitrary : ('a, 'x) Arbitrary.t -> 'a RandomGen.t
+ val arbitrary : ('a, 'x) ArbitraryRep.t -> 'a RandomGen.t
(** Extracts the random value generator. *)
- val withGen : 'a RandomGen.t -> ('a, 'x) Arbitrary.t UnOp.t
+ val withGen : 'a RandomGen.t -> ('a, 'x) ArbitraryRep.t UnOp.t
(** Functionally updates the random value generator. *)
end
signature ARBITRARY_CASES = sig
include OPEN_CASES ARBITRARY
- sharing Rep = Arbitrary
+ sharing Rep = ArbitraryRep
end
signature WITH_ARBITRARY_DOM = sig
include OPEN_CASES HASH TYPE_INFO
- sharing Rep = Hash = TypeInfo
+ sharing Rep = HashRep = TypeInfoRep
structure RandomGen : RANDOM_GEN
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -25,29 +25,29 @@
* of some other generics (e.g. pickling).
*)
signature DATA_REC_INFO = sig
- structure DataRecInfo : OPEN_REP
+ structure DataRecInfoRep : OPEN_REP
- val mayBeCyclic : ('a, 'x) DataRecInfo.t UnPr.t
+ val mayBeCyclic : ('a, 'x) DataRecInfoRep.t UnPr.t
(**
* Returns true if {'a} is a mutable type and may be part of a
* recursive datatype or contain exceptions. This means that values of
* the type can form cycles.
*)
- val mayContainExn : ('a, 'x) DataRecInfo.t UnPr.t
+ val mayContainExn : ('a, 'x) DataRecInfoRep.t UnPr.t
(**
* Returns true if a value of the type {'a} may contain exceptions.
* Arrow types are not considered to contain exceptions.
*)
- val mayBeRecData : ('a, 'x) DataRecInfo.t UnPr.t
+ val mayBeRecData : ('a, 'x) DataRecInfoRep.t UnPr.t
(**
* Returns true if a value of type {'a} may be part of a recursive
* datatype. Exceptions are not considered to be a recursive datatype
* and arrow types are not considered to contain recursive datatypes.
*)
- val isMutableType : ('a, 'x) DataRecInfo.t UnPr.t
+ val isMutableType : ('a, 'x) DataRecInfoRep.t UnPr.t
(**
* Returns true iff the type {'a} is of the form {'b Array.t} or of the
* form {'b Ref.t}.
@@ -56,5 +56,5 @@
signature DATA_REC_INFO_CASES = sig
include OPEN_CASES DATA_REC_INFO
- sharing Rep = DataRecInfo
+ sharing Rep = DataRecInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -7,18 +7,18 @@
(**
* Signature for a generic, structural, dynamic type.
*
- * The coercion functions {toDyn} and {fromDyn} take time relative to the
- * size of the structural encoding of the values. Mutable types, {ref}s
- * and {array}s, are not supported---encoding would not preserve the
- * identity of mutable values. Arrow types are supported, but coercing a
- * function to a dynamic value and then back returns a function wrapped
- * with coercions.
+ * The coercion functions {toDynamic} and {fromDynamic} take time relative
+ * to the size of the structural encoding of the values. Mutable types,
+ * {ref}s and {array}s, are not supported---encoding would not preserve
+ * the identity of mutable values. Arrow types are supported, but
+ * coercing a function to a dynamic value and then back returns a function
+ * wrapped with coercions.
*
* In contrast to the universal type provided by the {Univ} structure, the
* provided dynamic type is structural. Consider the following code:
*
- *> val x = toDyn (list int) [5]
- *> val SOME [5] = fromDyn (list int) x
+ *> val x = toDynamic (list int) [5]
+ *> val SOME [5] = fromDynamic (list int) x
*
* Even though the generic representation {list int} is computed twice,
* the above code evaluates without raising a {Bind} exception.
@@ -32,7 +32,7 @@
* between values of such types do not fail (by default).
*
* This design is experimental. An interesting design alternative would
- * be to allow more coercions to occur in {fromDyn}. For example,
+ * be to allow more coercions to occur in {fromDynamic}. For example,
* coercions between different scalar sizes and types could be performed
* implicitly. It would also be possible to coerce between vectors and
* lists of different element type. One could even implicitly read values
@@ -49,18 +49,18 @@
* registering exception constructors.
*)
signature DYNAMIC = sig
- structure Dynamic : OPEN_REP
+ structure DynamicRep : OPEN_REP
- structure Dyn : sig
+ structure Dynamic : sig
type t
- exception Dyn
+ exception Dynamic
end
- val toDyn : ('a, 'x) Dynamic.t -> 'a -> Dyn.t
- val fromDyn : ('a, 'x) Dynamic.t -> Dyn.t -> 'a Option.t
+ val toDynamic : ('a, 'x) DynamicRep.t -> 'a -> Dynamic.t
+ val fromDynamic : ('a, 'x) DynamicRep.t -> Dynamic.t -> 'a Option.t
end
signature DYNAMIC_CASES = sig
include OPEN_CASES DYNAMIC
- sharing Rep = Dynamic
+ sharing Rep = DynamicRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -39,15 +39,15 @@
* Comparison of functions is impossible and fails at run-time.
*)
signature EQ = sig
- structure Eq : OPEN_REP
+ structure EqRep : OPEN_REP
- val eq : ('a, 'x) Eq.t -> 'a BinPr.t
+ val eq : ('a, 'x) EqRep.t -> 'a BinPr.t
(** Extracts the equality predicate. *)
- val notEq : ('a, 'x) Eq.t -> 'a BinPr.t
+ val notEq : ('a, 'x) EqRep.t -> 'a BinPr.t
(** {notEq t = not o eq t} *)
- val withEq : 'a BinPr.t -> ('a, 'x) Eq.t UnOp.t
+ val withEq : 'a BinPr.t -> ('a, 'x) EqRep.t UnOp.t
(**
* Functionally updates the equality predicate.
*
@@ -61,5 +61,5 @@
signature EQ_CASES = sig
include OPEN_CASES EQ
- sharing Rep = Eq
+ sharing Rep = EqRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -22,10 +22,12 @@
* functions, because it is impossible to compare functions for equality.
*)
signature HASH = sig
- structure Hash : OPEN_REP
+ structure HashRep : OPEN_REP
- val hashParam :
- ('a, 'x) Hash.t -> {totWidth : Int.t, maxDepth : Int.t} -> 'a -> Word.t
+ val hashParam : ('a, 'x) HashRep.t
+ -> {totWidth : Int.t,
+ maxDepth : Int.t}
+ -> 'a -> Word.t
(**
* Returns a hash function. The {totWidth} and {maxDepth} parameters
* give some control over hashing. The {totWidth} parameter controls
@@ -34,16 +36,16 @@
* function descends into a (possibly recursive) datatype.
*)
- val hash : ('a, 'x) Hash.t -> 'a -> Word.t
+ val hash : ('a, 'x) HashRep.t -> 'a -> Word.t
(** Returns the default hash function. *)
end
signature HASH_CASES = sig
include OPEN_CASES HASH
- sharing Rep = Hash
+ sharing Rep = HashRep
end
signature WITH_HASH_DOM = sig
include OPEN_CASES TYPE_HASH TYPE_INFO
- sharing Rep = TypeHash = TypeInfo
+ sharing Rep = TypeHashRep = TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -36,18 +36,18 @@
* Comparison of functions is impossible and fails at run-time.
*)
signature ORD = sig
- structure Ord : OPEN_REP
+ structure OrdRep : OPEN_REP
- val ord : ('a, 'x) Ord.t -> 'a Cmp.t
+ val ord : ('a, 'x) OrdRep.t -> 'a Cmp.t
(** Extracts the linear ordering. *)
- val withOrd : 'a Cmp.t -> ('a, 'x) Ord.t UnOp.t
+ val withOrd : 'a Cmp.t -> ('a, 'x) OrdRep.t UnOp.t
(** Functionally updates the comparison function. *)
end
signature ORD_CASES = sig
include OPEN_CASES ORD
- sharing Rep = Ord
+ sharing Rep = OrdRep
end
signature WITH_ORD_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -108,9 +108,9 @@
* If you really need it (due to efficiency), let us know.
*)
signature PICKLE = sig
- structure Pickle : OPEN_REP
+ structure PickleRep : OPEN_REP
- structure Pickling : sig
+ structure Pickle : sig
exception TypeMismatch
(** Raised by unpickling functions when a type-mismatch is detected. *)
end
@@ -122,10 +122,10 @@
* pickle in memory as a whole.
*)
- 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
+ val pickler : ('a, 'x) PickleRep.t -> (Char.t -> (Unit.t, 's) IOSMonad.t)
+ -> ('a -> (Unit.t, 's) IOSMonad.t)
+ val unpickler : ('a, 'x) PickleRep.t -> (Char.t, 's) IOSMonad.t
+ -> ('a, 's) IOSMonad.t
(** == Simplified Interface ==
*
@@ -133,16 +133,17 @@
* 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
+ val pickle : ('a, 'x) PickleRep.t -> 'a -> String.t
+ val unpickle : ('a, 'x) PickleRep.t -> String.t -> 'a
end
signature PICKLE_CASES = sig
include OPEN_CASES PICKLE
- sharing Rep = Pickle
+ sharing Rep = PickleRep
end
signature WITH_PICKLE_DOM = sig
include OPEN_CASES DATA_REC_INFO EQ HASH SOME TYPE_HASH TYPE_INFO
- sharing Rep = DataRecInfo = Eq = Hash = Some = TypeHash = TypeInfo
+ sharing Rep = DataRecInfoRep = EqRep = HashRep = SomeRep = TypeHashRep
+ = TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -6,15 +6,31 @@
(**
* Signature for a generic function for pretty-printing values of
- * arbitrary SML types.
+ * arbitrary Standard ML types.
*
* Features:
+ * - The result is a document that can be rendered to a desired width
+ * (number of columns).
+ * - The output is roughly as close to Standard ML syntax as possible.
+ * - Eliminates unnecessary parentheses from the output.
+ * - Can optionally pretty print only a part of the value (up to given
+ * datatype depth and sequence or string length). Partial data is
+ * indicated as "\..." (an illegal escape sequence) in strings and as
+ * "..." otherwise.
+ * - The default formatting of integers, words, and reals can be
+ * specified.
+ * - The radix of integers and words is shown in the output with a "b"
+ * (binary ; HaMLet-S), "o" (octal ; non-standard), or "x" prefix.
+ * - Sharing of mutable objects is shown in the output. Shared mutable
+ * objects are assigned a sequence number, indicated by a "#n=" prefix at
+ * the first occurrence. Subsequent occurrences of the shared object are
+ * indicated by a "#n".
* - Handles arbitrary cyclic data structures.
- * - Shows sharing.
- * - Output roughly as close to SML syntax as possible.
+ * - Supports pretty printing infix constructors in infix notation with a
+ * given fixity.
*)
signature PRETTY = sig
- structure Pretty : OPEN_REP
+ structure PrettyRep : OPEN_REP
(** Substructure for specifying formatting options. *)
structure Fmt : sig
@@ -28,7 +44,7 @@
* Example:
*
*> let open Fmt in default & maxDepth := SOME 3
- *> & maxLength := SOME 10 end
+ *> & intRadix := StringCvt.HEX end
*)
val & : t * ('a opt * 'a) -> t
@@ -43,29 +59,73 @@
val ! : 'a opt -> t -> 'a
- (** == Options == *)
+ (** == Options ==
+ *
+ * The defaults for scalar types have been chosen to match the
+ * {X.toString} functions provided by the Basis library with the
+ * exception.
+ *)
val intRadix : StringCvt.radix opt (** default: {StringCvt.DEC} *)
- val wordRadix : StringCvt.radix opt (** default: {StringCvt.HEX} *)
- val realFmt : StringCvt.realfmt opt (** default: {StringCvt.GEN NONE} *)
val maxDepth : Int.t Option.t opt (** default: {NONE} *)
val maxLength : Int.t Option.t opt (** default: {NONE} *)
val maxString : Int.t Option.t opt (** default: {NONE} *)
+ val realFmt : StringCvt.realfmt opt (** default: {StringCvt.GEN NONE} *)
+ val wordRadix : StringCvt.radix opt (** default: {StringCvt.HEX} *)
end
- val fmt : ('a, 'x) Pretty.t -> Fmt.t -> 'a -> Prettier.t
+ (** Substructure for additional pretty printing combinators. *)
+ structure Pretty : sig
+ (** == Infix Constructors ==
+ *
+ * The {infixL} and {infixR} combinators update a given sum type
+ * representation to print the value with an infix constructor.
+ *
+ * As an example, consider the following type representation
+ * constructor definition:
+ *
+ *> local
+ *> val et = C "&"
+ *> in
+ *> fun a &` b =
+ *> iso (data (Pretty.infixL 0 et (a, b)
+ *> (C1 et (tuple2 (a, b)))))
+ *> (fn op & ? => ?, op &)
+ *> end
+ *
+ * Now,
+ *
+ *> show (int &` int &` int) (1 & 2 & 3)
+ *
+ * would evaluate to
+ *
+ *> "1 & 2 & 3"
+ *)
+
+ val infixL : Int.t
+ -> Generics.Con.t
+ -> ('a, 'x) PrettyRep.t * ('b, 'y) PrettyRep.t
+ -> ('a * 'b, 'z) PrettyRep.s UnOp.t
+
+ val infixR : Int.t
+ -> Generics.Con.t
+ -> ('a, 'x) PrettyRep.t * ('b, 'y) PrettyRep.t
+ -> ('a * 'b, 'z) PrettyRep.s UnOp.t
+ end
+
+ val fmt : ('a, 'x) PrettyRep.t -> Fmt.t -> 'a -> Prettier.t
(** Extracts the prettifying function. *)
- val pretty : ('a, 'x) Pretty.t -> 'a -> Prettier.t
+ val pretty : ('a, 'x) PrettyRep.t -> 'a -> Prettier.t
(** {pretty t} is equivalent to {fmt t Fmt.default}. *)
- val show : ('a, 'x) Pretty.t -> 'a -> String.t
+ val show : ('a, 'x) PrettyRep.t -> 'a -> String.t
(** {show t} is equivalent to {Prettier.render NONE o pretty t}. *)
end
signature PRETTY_CASES = sig
include OPEN_CASES PRETTY
- sharing Rep = Pretty
+ sharing Rep = PrettyRep
end
signature WITH_PRETTY_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -5,32 +5,33 @@
*)
(**
- * A signature for a generic dummy value. In SML, dummy values are needed
- * for things such as computing fixpoints and building cyclic values.
+ * A signature for a generic dummy value. In Standard ML, dummy values
+ * are needed for things such as computing fixpoints and building cyclic
+ * values.
*
* This generic is unlikely to be directly useful in application programs
* and is more likely to be used internally in the implementation of some
* other generics (e.g. pickling).
*)
signature SOME = sig
- structure Some : OPEN_REP
+ structure SomeRep : OPEN_REP
exception Nothing of Exn.t
(** Raised when trying to extract some value when there is none. *)
- val some : ('a, 'x) Some.t -> 'a
+ val some : ('a, 'x) SomeRep.t -> 'a
(** Returns some value of type {'a} or raises {Nothing}. *)
- val withNone : ('a, 'x) Some.t UnOp.t
+ val withNone : ('a, 'x) SomeRep.t UnOp.t
(** Removes any value from the given representation. *)
- val withSome : 'a -> ('a, 'x) Some.t UnOp.t
+ val withSome : 'a -> ('a, 'x) SomeRep.t UnOp.t
(** Sets the value of the given representation. *)
end
signature SOME_CASES = sig
include OPEN_CASES SOME
- sharing Rep = Some
+ sharing Rep = SomeRep
end
signature WITH_SOME_DOM = TYPE_INFO_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -10,13 +10,13 @@
* WARNING: The hash function is not designed to be secure in any way.
*)
signature TYPE_HASH = sig
- structure TypeHash : OPEN_REP
+ structure TypeHashRep : OPEN_REP
- val typeHash : ('a, 'x) TypeHash.t -> Word32.t
+ val typeHash : ('a, 'x) TypeHashRep.t -> Word32.t
(** Returns a hash value specific to the type. *)
end
signature TYPE_HASH_CASES = sig
include OPEN_CASES TYPE_HASH
- sharing Rep = TypeHash
+ sharing Rep = TypeHashRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -18,23 +18,23 @@
* of some other generics (e.g. hashing).
*)
signature TYPE_INFO = sig
- structure TypeInfo : OPEN_REP
+ structure TypeInfoRep : OPEN_REP
(** == Sums == *)
- val hasBaseCase : ('a, 'x) TypeInfo.s UnPr.t
+ val hasBaseCase : ('a, 'x) TypeInfoRep.s UnPr.t
(** Returns true iff the type {'a} has a non-recursive variant. *)
- val numAlts : ('a, 'x) TypeInfo.s -> Int.t
+ val numAlts : ('a, 'x) TypeInfoRep.s -> Int.t
(** Number of alternatives in the given incomplete sum. *)
(** == Products == *)
- val numElems : ('a, 'k, 'x) TypeInfo.p -> Int.t
+ val numElems : ('a, 'k, 'x) TypeInfoRep.p -> Int.t
(** Number of elements in the given incomplete product. *)
end
signature TYPE_INFO_CASES = sig
include OPEN_CASES TYPE_INFO
- sharing Rep = TypeInfo
+ sharing Rep = TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -40,7 +40,7 @@
val p = pickle t (some t)
in
verifyFailsWith
- (fn Pickling.TypeMismatch => true | _ => false)
+ (fn Pickle.TypeMismatch => true | _ => false)
(fn () => unpickle u p)
end)
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -43,9 +43,9 @@
(tst (SOME 22)
((order |` unit) &` order &` (unit |` order))
- "&\n\
- \ (& (INL LESS, EQUAL),\n\
- \ INR GREATER)"
+ "INL LESS\n\
+ \& EQUAL\n\
+ \& INR GREATER"
(INL LESS & EQUAL & INR GREATER))
let
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml 2007-09-19 10:22:43 UTC (rev 6033)
@@ -12,16 +12,16 @@
in
open Extra
end
- structure Arbitrary = Open.Rep
- structure DataRecInfo = Open.Rep
- structure Eq = Open.Rep
- structure Hash = Open.Rep
- structure Ord = Open.Rep
- structure Pickle = Open.Rep
- structure Pretty = Open.Rep
- structure Some = Open.Rep
- structure TypeHash = Open.Rep
- structure TypeInfo = Open.Rep
+ structure ArbitraryRep = Open.Rep
+ structure DataRecInfoRep = Open.Rep
+ structure EqRep = Open.Rep
+ structure HashRep = Open.Rep
+ structure OrdRep = Open.Rep
+ structure PickleRep = Open.Rep
+ structure PrettyRep = Open.Rep
+ structure SomeRep = Open.Rep
+ structure TypeHashRep = Open.Rep
+ structure TypeInfoRep = Open.Rep
end
(* Register basis library exceptions for the default generics. *)
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-19 07:39:01 UTC (rev 6032)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-19 10:22:43 UTC (rev 6033)
@@ -9,7 +9,7 @@
*)
signature MK_UNIT_TEST_DOM = sig
include GENERIC
- include ARBITRARY sharing Open.Rep = Arbitrary
- include EQ sharing Open.Rep = Eq
- include PRETTY sharing Open.Rep = Pretty
+ include ARBITRARY sharing Open.Rep = ArbitraryRep
+ include EQ sharing Open.Rep = EqRep
+ include PRETTY sharing Open.Rep = PrettyRep
end
More information about the MLton-commit
mailing list