[MLton-commit] r5632
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 08:11:55 PDT 2007
Renamed Show -> Pretty.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
D mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
D mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-16 15:11:54 UTC (rev 5632)
@@ -11,12 +11,12 @@
include EQ sharing Open.Rep = Eq
include HASH sharing Open.Rep = Hash
include ORD sharing Open.Rep = Ord
- include SHOW sharing Open.Rep = Show
+ include PRETTY sharing Open.Rep = Pretty
include TYPE_INFO sharing Open.Rep = TypeInfo
end = struct
structure Open = RootGeneric
- structure Open = WithShow (Open) open Open
+ structure Open = WithPretty (Open) open Open
structure Open = WithTypeInfo (Open) open Open structure TypeInfo = Open
structure Open = WithEq (Open) open Open
structure Open = WithOrd (Open) open Open
@@ -42,7 +42,7 @@
structure Eq = Open.Rep
structure Hash = Open.Rep
structure Ord = Open.Rep
- structure Show = Open.Rep
+ structure Pretty = Open.Rep
structure TypeInfo = Open.Rep
structure Generic = struct
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-16 15:11:54 UTC (rev 5632)
@@ -22,7 +22,7 @@
../../../public/value/eq.sig
../../../public/value/hash.sig
../../../public/value/ord.sig
- ../../../public/value/show.sig
+ ../../../public/value/pretty.sig
../../../public/value/type-info.sig
../../close-generic.fun
../../generics-util.sml
@@ -36,6 +36,6 @@
../../value/eq.sml
../../value/hash.sml
../../value/ord.sml
- ../../value/show.sml
+ ../../value/pretty.sml
../../value/type-info.sml
../../with-extra.fun
Copied: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml (from rev 5626, mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-16 09:32:54 UTC (rev 5626)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-06-16 15:11:54 UTC (rev 5632)
@@ -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 *)
+
+local
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >|
+ infixr 2 |<
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure Pretty : CLOSED_GENERIC = struct
+ 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 Rep = MkClosedGenericRep (type 'a t = exn list * 'a -> u)
+
+ 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 Rep.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 Rep.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 (* Word16 not provided by SML/NJ *) *)
+ val word32 = mkWord Word32.toString
+ val word64 = mkWord Word64.toString
+ end
+
+ structure Pretty : OPEN_GENERIC = OpenGeneric (Pretty)
+in
+ structure Pretty :> PRETTY_GENERIC = struct
+ open Pretty
+ structure Pretty = Rep
+ val layout : ('a, 'x) Pretty.t -> 'a -> Prettier.t =
+ fn (t, _) => Pair.snd o [] <\ t
+ fun pretty m t = Prettier.pretty m o layout t
+ end
+end
+
+functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Arg and Inner = Pretty)
+ open Joined
+ fun layout ? = Pretty.layout (Arg.Rep.getT ?)
+ fun pretty m = Pretty.pretty m o Arg.Rep.getT
+ structure Pretty = Rep
+end
Deleted: mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-16 15:11:54 UTC (rev 5632)
@@ -1,206 +0,0 @@
-(* 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 *)
-
-local
- (* <-- SML/NJ workaround *)
- open TopLevel
- infix 7 *`
- infix 6 +`
- infixr 6 <^> <+>
- infixr 5 <$> <$$> </> <//>
- infix 4 <\ \>
- infixr 4 </ />
- infix 2 >|
- infixr 2 |<
- infix 0 &
- infixr 0 -->
- (* SML/NJ workaround --> *)
-
- structure Show : CLOSED_GENERIC = struct
- 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 Rep = MkClosedGenericRep (type 'a t = exn list * 'a -> u)
-
- 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 Rep.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 Rep.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 (* Word16 not provided by SML/NJ *) *)
- val word32 = mkWord Word32.toString
- val word64 = mkWord Word64.toString
- end
-
- structure Show : OPEN_GENERIC = OpenGeneric (Show)
-in
- structure Show :> SHOW_GENERIC = struct
- open Show
- structure Show = Rep
- val layout : ('a, 'x) Show.t -> 'a -> Prettier.t =
- fn (t, _) => Pair.snd o [] <\ t
- fun show m t = Prettier.pretty m o layout t
- end
-end
-
-functor WithShow (Arg : OPEN_GENERIC) : SHOW_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = Show)
- open Joined
- fun layout ? = Show.layout (Arg.Rep.getT ?)
- fun show m = Show.show m o Arg.Rep.getT
- structure Show = Rep
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-16 15:11:54 UTC (rev 5632)
@@ -69,8 +69,8 @@
public/value/ord.sig
detail/value/ord.sml
- public/value/show.sig
- detail/value/show.sml
+ public/value/pretty.sig
+ detail/value/pretty.sml
public/value/hash.sig
detail/value/hash.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-16 15:11:54 UTC (rev 5632)
@@ -36,8 +36,8 @@
signature ORD = ORD
signature ORD_GENERIC = ORD_GENERIC
-signature SHOW = SHOW
-signature SHOW_GENERIC = SHOW_GENERIC
+signature PRETTY = PRETTY
+signature PRETTY_GENERIC = PRETTY_GENERIC
signature TYPE_INFO = TYPE_INFO
signature TYPE_INFO_GENERIC = TYPE_INFO_GENERIC
@@ -107,7 +107,7 @@
functor WithOrd (Arg : OPEN_GENERIC) : ORD_GENERIC = WithOrd (Arg)
-functor WithShow (Arg : OPEN_GENERIC) : SHOW_GENERIC = WithShow (Arg)
+functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = WithPretty (Arg)
functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC =
WithTypeInfo (Arg)
Copied: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig (from rev 5624, mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig 2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-06-16 15:11:54 UTC (rev 5632)
@@ -0,0 +1,24 @@
+(* 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 generic function for pretty printing values of
+ * arbitrary SML datatypes.
+ *)
+signature PRETTY = sig
+ structure Pretty : OPEN_GENERIC_REP
+
+ val layout : ('a, 'x) Pretty.t -> 'a -> Prettier.t
+ (** Extracts the prettifying function. *)
+
+ val pretty : Int.t Option.t -> ('a, 'x) Pretty.t -> 'a -> String.t
+ (** {pretty m t = Prettier.pretty m o layout t} *)
+end
+
+signature PRETTY_GENERIC = sig
+ include OPEN_GENERIC PRETTY
+ sharing Rep = Pretty
+end
Deleted: mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig 2007-06-16 14:51:36 UTC (rev 5631)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/show.sig 2007-06-16 15:11:54 UTC (rev 5632)
@@ -1,25 +0,0 @@
-(* 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 generic function for pretty printing values of
- * arbitrary SML datatypes. See [http://mlton.org/TypeRepedValues]
- * for further discussion.
- *)
-signature SHOW = sig
- structure Show : OPEN_GENERIC_REP
-
- 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 OPEN_GENERIC SHOW
- sharing Rep = Show
-end
More information about the MLton-commit
mailing list