[MLton-commit] r6072
Vesa Karvonen
vesak at mlton.org
Thu Oct 18 11:10:05 PDT 2007
Added three new formatting options: conNest, contString, and fieldNest.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-15 17:24:00 UTC (rev 6071)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-18 18:10:03 UTC (rev 6072)
@@ -6,13 +6,22 @@
(* XXX indentation formatting option(s) *)
+datatype cont_string =
+ ALWAYS_AT_NL
+ | AT_NL_TO_FIT
+ | NEVER_CONT
+
functor MkOpts (type 'a t) = struct
- type t = {intRadix : StringCvt.radix t,
- wordRadix : StringCvt.radix t,
- realFmt : StringCvt.realfmt t,
- maxDepth : Int.t Option.t t,
- maxLength : Int.t Option.t t,
- maxString : Int.t Option.t t}
+ type t =
+ {conNest : Int.t Option.t t,
+ contString : cont_string t,
+ fieldNest : Int.t Option.t t,
+ intRadix : StringCvt.radix t,
+ maxDepth : Int.t Option.t t,
+ maxLength : Int.t Option.t t,
+ maxString : Int.t Option.t t,
+ realFmt : StringCvt.realfmt t,
+ wordRadix : StringCvt.radix t}
end
functor MapOpts (type 'a dom and 'a cod
@@ -20,12 +29,15 @@
structure Dom = MkOpts (type 'a t = 'a dom)
structure Cod = MkOpts (type 'a t = 'a cod)
fun map (r : Dom.t) : Cod.t =
- {intRadix = f (#intRadix r),
- wordRadix = f (#wordRadix r),
- realFmt = f (#realFmt r),
- maxDepth = f (#maxDepth r),
+ {conNest = f (#conNest r),
+ contString = f (#contString r),
+ fieldNest = f (#fieldNest r),
+ intRadix = f (#intRadix r),
+ maxDepth = f (#maxDepth r),
maxLength = f (#maxLength r),
- maxString = f (#maxString r)}
+ maxString = f (#maxString r),
+ realFmt = f (#realFmt r),
+ wordRadix = f (#wordRadix r)}
end
functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = struct
@@ -64,17 +76,22 @@
fun atomize (a, d) = if ATOMIC = a then d else surround parens d
structure Fmt = struct
+ datatype cont_string = datatype cont_string
+
structure Opts = MkOpts (type 'a t = 'a)
datatype t = T of Opts.t
val default =
- T {intRadix = StringCvt.DEC,
- wordRadix = StringCvt.HEX,
- realFmt = StringCvt.GEN NONE,
- maxDepth = NONE,
+ T {conNest = SOME 1,
+ contString = AT_NL_TO_FIT,
+ fieldNest = SOME 1,
+ intRadix = StringCvt.DEC,
+ maxDepth = NONE,
maxLength = NONE,
- maxString = NONE}
+ maxString = NONE,
+ realFmt = StringCvt.GEN NONE,
+ wordRadix = StringCvt.HEX}
structure RefOpts = MkOpts (Ref)
@@ -94,12 +111,15 @@
then raise Size
else ()
- val intRadix = O {get = #intRadix, set = #intRadix, chk = ignore}
- val wordRadix = O {get = #wordRadix, set = #wordRadix, chk = ignore}
- val realFmt = O {get = #realFmt, set = #realFmt, chk = chkRealFmt}
- val maxDepth = O {get = #maxDepth, set = #maxDepth, chk = notNegOpt}
+ val conNest = O {get = #conNest, set = #conNest, chk = notNegOpt}
+ val contString = O {get = #contString, set = #contString, chk = ignore}
+ val fieldNest = O {get = #fieldNest, set = #fieldNest, chk = notNegOpt}
+ val intRadix = O {get = #intRadix, set = #intRadix, chk = ignore}
+ val maxDepth = O {get = #maxDepth, set = #maxDepth, chk = notNegOpt}
val maxLength = O {get = #maxLength, set = #maxLength, chk = notNegOpt}
val maxString = O {get = #maxString, set = #maxString, chk = notNegOpt}
+ val realFmt = O {get = #realFmt, set = #realFmt, chk = chkRealFmt}
+ val wordRadix = O {get = #wordRadix, set = #wordRadix, chk = ignore}
structure I = MapOpts (type 'a dom = 'a and 'a cod = 'a Ref.t val f = ref)
and P = MapOpts (type 'a dom = 'a Ref.t and 'a cod = 'a val f = !)
@@ -167,7 +187,7 @@
of SOME (SOME u) => u <^> equals
| _ => empty) <^> d))
- fun sequ style toSlice getItem aP (e as E ({fmt, ...}, _), a) = let
+ fun sequ style toSlice getItem aP (e as E ({fmt = Fmt.T r, ...}, _), a) = let
fun lp (n, d, s) =
case getItem s
of NONE => surround style d
@@ -181,12 +201,12 @@
open Fmt
in
(ATOMIC,
- if SOME 0 = !maxLength fmt
+ if SOME 0 = #maxLength r
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))
+ lp (OptInt.- (#maxLength r, SOME 1), group (aP (e, a)), s))
end
val intPrefix =
@@ -215,6 +235,16 @@
then (ATOMIC, txtDots)
else aP (E (c, {maxDepth = OptInt.- (maxDepth, SOME 1)}), v)
+ fun nested (m, lhs, frhs, s) (ex as (E ({fmt = Fmt.T r, ...}, _), _)) = let
+ val rhs = frhs ex
+ fun next n = nest n (lhs <$> rhs)
+ fun same () = nest m (lhs <+> rhs)
+ in
+ group (case s r
+ of SOME n => if m <= n then same () else next n
+ | NONE => same ())
+ end
+
val exnHandler : Exn.t t Ref.t =
ref (mark ATOMIC o txtHash <\ op <^> o txt o General.exnName o #2)
fun regExn aP e2a =
@@ -312,10 +342,13 @@
fn (e, a & b) => aP (e, a) <^> comma <$> bP (e, b)
end
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 R l = let
+ val s = Generics.Label.toString l
+ val t = txt s <+> equals
+ val m = String.length s + 2
+ in
+ fn aT => nested (m, t, T aT, #fieldNest)
+ end
fun tuple aP = mark ATOMIC o surround parens o getP aP
fun record aP = mark ATOMIC o surround braces o getP aP
@@ -328,10 +361,13 @@
end
fun unit _ = (ATOMIC, txtUnit)
fun C0 c = const (ATOMIC, txt (Generics.Con.toString c))
- fun C1 c =
- case txt (Generics.Con.toString c)
- of c => fn aT => case getT aT of aP => fn ex =>
- (NONFIX, nest 1 (group (c <$> atomize (aP ex))))
+ fun C1 c = let
+ val s = Generics.Con.toString c
+ val t = txt s
+ val m = String.length s + 1
+ in
+ fn aT => mark NONFIX o nested (m, t, atomize o getT aT, #conNest)
+ end
fun data aS = depth (getS aS)
val Y = Tie.function
@@ -354,20 +390,24 @@
local
val toLit = txt o Substring.translate Char.toString
in
- fun string (E ({fmt = Fmt.T {maxString, ...}, ...}, _), s) = let
- val cut = isSome maxString andalso valOf maxString < size s
- val suf = if cut then txtBsDots else empty
- val s = if cut
- then Substring.substring (s, 0, valOf maxString)
- else Substring.full s
+ fun string (E ({fmt = Fmt.T r, ...}, _), s) = let
+ val l = size s
+ val n = Int.min (getOpt (#maxString r, l), l)
+ val suf = if n < l then txtBsDots else empty
+ val s = Substring.substring (s, 0, n)
+ fun wide () = toLit s
+ fun narrow () =
+ List.foldl1
+ (fn (x, s) => s <^> txtNlBs <$> backslash <^> x)
+ (List.map toLit (Substring.fields (#"\n" <\ op =) s))
in
- mark ATOMIC o dquotes |< choice
- {wide = toLit s <^> suf,
- narrow = lazy (fn () =>
- List.foldl1
- (fn (x, s) => s <^> txtNlBs <$> backslash <^> x)
- (List.map toLit (Substring.fields (#"\n" <\ op =) s)) <^>
- suf)}
+ (ATOMIC,
+ dquotes ((case #contString r
+ of ALWAYS_AT_NL => narrow ()
+ | AT_NL_TO_FIT =>
+ choice {wide = wide (), narrow = lazy narrow}
+ | NEVER_CONT => wide ())
+ <^> suf))
end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-10-15 17:24:00 UTC (rev 6071)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-10-18 18:10:03 UTC (rev 6072)
@@ -60,19 +60,110 @@
val ! : 'a opt -> t -> 'a
- (** == Options ==
+ (** == Options == *)
+
+ (** === Record Formatting Options === *)
+
+ val fieldNest : Int.t Option.t opt
+ (**
+ * Number of columns of nesting for field value on the next line.
*
+ * default: {SOME 1}
+ *
+ * Specifying {NONE} means that the value is always placed on the
+ * same line with the field name. This usually results in wide
+ * layouts.
+ *
+ * If the field name is narrow enough (e.g. 1 or 2 chars) and the
+ * nesting is large enough (e.g. 4 columns) that placing the
+ * value on the next line does not decrease the indentation of
+ * the value, it will placed on the same line with the field name.
+ *)
+
+ (** === Scalar Formatting 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 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} *)
+ val intRadix : StringCvt.radix opt
+ (**
+ * Integer radix. Only applies to the formatting of int types.
+ *
+ * default: {StringCvt.DEC}
+ *)
+
+ val realFmt : StringCvt.realfmt opt
+ (**
+ * Real format. Only applies to the formatting of real types.
+ *
+ * default: {StringCvt.GEN NONE}
+ *)
+
+ val wordRadix : StringCvt.radix opt
+ (**
+ * Word radix. Only applies to the formatting of word types.
+ *
+ * default: {StringCvt.HEX}
+ *)
+
+ (** === Partial Output Options === *)
+
+ val maxDepth : Int.t Option.t opt
+ (**
+ * Maximum data depth to show.
+ *
+ * default: {NONE}
+ *)
+
+ val maxLength : Int.t Option.t opt
+ (**
+ * Maximum sequence length to show.
+ *
+ * default: {NONE}
+ *)
+
+ val maxString : Int.t Option.t opt
+ (**
+ * Maximum string size to show.
+ *
+ * default: {NONE}
+ *)
+
+ (** === String Formatting Options === *)
+
+ datatype cont_string =
+ ALWAYS_AT_NL
+ | AT_NL_TO_FIT
+ | NEVER_CONT
+
+ val contString : cont_string opt
+ (**
+ * How to use line continuations.
+ *
+ * default: {AT_NL_TO_FIT}
+ *)
+
+ (** === Datatype Formatting Options == *)
+
+ val conNest : Int.t Option.t opt
+ (**
+ * Number of columns of nesting for unary constructor argument on
+ * the next line.
+ *
+ * default: {SOME 1}
+ *
+ * Specifying {NONE} means that the argument is always placed on the
+ * same line with the constructor. This usually results in wide
+ * layouts.
+ *
+ * If the constructor is narrow enough (e.g. 1 to 3 chars) and the
+ * nesting is large enough (e.g. 4 columns) that placing the
+ * argument on the next line does not decrease the indentation of
+ * the argument, it will placed on the same line with the
+ * constructor.
+ *)
end
(** Substructure for additional pretty printing combinators. *)
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-10-15 17:24:00 UTC (rev 6071)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-10-18 18:10:03 UTC (rev 6072)
@@ -9,8 +9,8 @@
infix |`
- fun tst n t s v =
- testEq string (fn () => {expect = s, actual = render n (pretty t v)})
+ fun tst n f t s v =
+ testEq string (fn () => {expect = s, actual = render n (fmt t f v)})
structure Graph = MkGraph (Generic)
structure BinTree = MkBinTree (Generic)
@@ -19,30 +19,30 @@
unitTests
(title "Generic.Pretty")
- (tst NONE unit "()" ())
+ (tst NONE Fmt.default unit "()" ())
- (tst NONE word "0wx15" 0wx15)
+ (tst NONE Fmt.default word "0wx15" 0wx15)
- (tst (SOME 6) (list int)
+ (tst (SOME 6) Fmt.default (list int)
"[1,\n 2,\n 3]"
[1, 2, 3])
- (tst (SOME 2) (vector bool)
+ (tst (SOME 2) Fmt.default (vector bool)
"#[true,\n\
\ false]"
(Vector.fromList [true, false]))
- (tst (SOME 15) (tuple3 (option unit, string, exn))
+ (tst (SOME 15) Fmt.default (tuple3 (option unit, string, exn))
"(NONE,\n\
\ \"a\",\n\
\ Empty)"
(NONE, "a", Empty))
- (tst NONE (array unit) "#()" (Array.array (0, ())))
+ (tst NONE Fmt.default (array unit) "#()" (Array.array (0, ())))
- (tst NONE real "~3.141" ~3.141)
+ (tst NONE Fmt.default real "~3.141" ~3.141)
- (tst (SOME 22)
+ (tst (SOME 22) Fmt.default
((order |` unit) &` order &` (unit |` order))
"INL LESS\n\
\& EQUAL\n\
@@ -50,7 +50,7 @@
(INL LESS & EQUAL & INR GREATER))
let
- fun chk s e = tst (SOME 11) string e s
+ fun chk s e = tst (SOME 11) Fmt.default string e s
in
fn ? =>
(pass ?)
@@ -63,31 +63,32 @@
let
exception Unknown
in
- tst NONE exn "#Unknown" Unknown
+ tst NONE Fmt.default exn "#Unknown" Unknown
end
(tst (SOME 9)
+ let open Fmt in default & fieldNest := SOME 4 end
(iso (record (R' "1" int
- *` R' "+" (unOp int)
- *` R' "c" char))
- (fn {1 = a, + = b, c = c} => a & b & c,
- fn a & b & c => {1 = a, + = b, c = c}))
- "{1 = 2,\n\
+ *` R' "+" (unOp int)
+ *` R' "long" char))
+ (fn {1 = a, + = b, long = c} => a & b & c,
+ fn a & b & c => {1 = a, + = b, long = c}))
+ "{1 = 200000000,\n\
\ + = #fn,\n\
- \ c =\n\
- \ #\"d\"}"
- {1 = 2, + = id, c = #"d"})
+ \ long =\n\
+ \ #\"d\"}"
+ {1 = 200000000, + = id, long = #"d"})
let
datatype s = S of s Option.t Ref.t Sq.t
val x as S (l, r) = S (ref NONE, ref NONE)
val () = (l := SOME x ; r := SOME x)
in
- tst (SOME 50)
- (Tie.fix Y
- (fn s =>
- iso (data (C1' "S" (sq (refc (option s)))))
- (fn S ? => ?, S)))
+ tst (SOME 50) Fmt.default
+ ((Tie.fix Y)
+ (fn s =>
+ iso (data (C1' "S" (sq (refc (option s)))))
+ (fn S ? => ?, S)))
"S\n\
\ (#0=ref\n\
\ (SOME (S (#0, #1=ref (SOME (S (#0, #1)))))),\n\
@@ -95,8 +96,7 @@
x
end
- (tst (SOME 50)
- (Graph.t int)
+ (tst (SOME 50) Fmt.default (Graph.t int)
"ref\n\
\ [VTX\n\
\ (1,\n\
@@ -134,14 +134,13 @@
return (ATOMIC, angles d))
in
tst (SOME 30)
+ let open Fmt in default & conNest := NONE end
(BinTree.t (mapPrinter withAngles int))
- "BR\n\
- \ (BR (LF, <0>, LF),\n\
- \ <1>,\n\
- \ BR\n\
- \ (LF,\n\
- \ <2>,\n\
- \ BR (LF, <3>, LF)))"
+ "BR (BR (LF, <0>, LF),\n\
+ \ <1>,\n\
+ \ BR (LF,\n\
+ \ <2>,\n\
+ \ BR (LF, <3>, LF)))"
(BR (BR (LF, 0, LF), 1, BR (LF, 2, BR (LF, 3, LF))))
end
More information about the MLton-commit
mailing list