[MLton-commit] r5997
Vesa Karvonen
vesak at mlton.org
Sun Sep 2 16:29:12 PDT 2007
Revised the interfaces of Prettier and Pretty. Some minor optimizations
in Pretty.
----------------------------------------------------------------------
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
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
U mltonlib/trunk/com/ssh/prettier/unstable/detail/prettier.sml
U mltonlib/trunk/com/ssh/prettier/unstable/public/prettier.sig
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-02 23:29:10 UTC (rev 5997)
@@ -47,8 +47,6 @@
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)
@@ -89,8 +87,16 @@
end) <^>
aP ((e, c), v))
- fun sequ style toL t (e, a) =
- surround style o fill o punctuate comma o List.map (curry t e) |< toL a
+ fun sequ style toSlice getItem aP (e, a) = let
+ fun lp (d, s) =
+ case getItem s
+ of NONE => surround style d
+ | SOME (a, s) => lp (d <^> comma <$> aP (e, a), s)
+ in
+ case getItem (toSlice a)
+ of NONE => atomic (Prettier.<^> (#2 style))
+ | SOME (a, s) => lp (aP (e, a), s)
+ end
fun mk toS : 'a t = txt o toS o Pair.snd
fun enc l r toS x = concat [l, toS x, r]
@@ -113,12 +119,11 @@
open Pretty.This
- fun layout t =
+ fun pretty t =
case getT t
of p => fn x => #2 (p ((HashMap.new {eq = HashUniv.eq,
hash = HashUniv.hash}, ref ~1), x))
- fun pretty m t = Prettier.pretty m o layout t
- fun show t = pretty NONE t
+ fun show t = Prettier.render NONE o pretty t
structure Layered = LayerDepCases
(structure Outer = Arg and Result = Pretty
@@ -165,12 +170,13 @@
fun regExn1 c aT = case C1 c aT of aP => regExn aP o Pair.snd
fun refc aT = cyclic (Arg.refc ignore aT) o flip inj ! |< C1 ctorRef aT
- fun array aT = cyclic (Arg.array ignore aT) |<
- sequ hashParens Array.toList (getT aT)
+ fun array aT =
+ cyclic (Arg.array ignore aT) |<
+ sequ hashParens ArraySlice.full ArraySlice.getItem (getT aT)
+ fun vector aT =
+ sequ hashBrackets VectorSlice.full VectorSlice.getItem (getT aT)
+ fun list aT = sequ brackets id List.getItem (getT aT)
- fun vector aT = sequ hashBrackets Vector.toList (getT aT)
- fun list aT = sequ brackets id (getT aT)
-
fun op --> _ = const txtFn
local
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-02 23:29:10 UTC (rev 5997)
@@ -5,20 +5,22 @@
*)
(**
- * Signature for a generic function for pretty printing values of
+ * Signature for a generic function for pretty-printing values of
* arbitrary SML datatypes.
+ *
+ * Features:
+ * - Handles arbitrary cyclic data structures.
+ * - Shows sharing.
+ * - Output roughly as close to SML syntax as possible.
*)
signature PRETTY = sig
structure Pretty : OPEN_REP
- val layout : ('a, 'x) Pretty.t -> 'a -> Prettier.t
+ val pretty : ('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} is equivalent to {Prettier.pretty m o layout t}. *)
-
val show : ('a, 'x) Pretty.t -> 'a -> String.t
- (** {show t} is equivalent to {pretty NONE t}. *)
+ (** {show t} is equivalent to {Prettier.render NONE (pretty t)}. *)
end
signature PRETTY_CASES = sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-02 23:29:10 UTC (rev 5997)
@@ -5,12 +5,12 @@
*)
local
- open Generic UnitTest
+ open Prettier Generic UnitTest
infix |`
fun tst n t s v =
- testEq string (fn () => {expect = s, actual = pretty n t v})
+ testEq string (fn () => {expect = s, actual = render n (pretty t v)})
structure Graph = MkGraph (Generic)
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-09-02 23:29:10 UTC (rev 5997)
@@ -5,8 +5,10 @@
*)
local
+ $(MLTON_LIB)/com/ssh/unit-test/unstable/lib-with-default.mlb
+
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/unit-test/unstable/lib-with-default.mlb
+ $(MLTON_LIB)/com/ssh/prettier/unstable/lib.mlb
lib-with-default.mlb
ann
Modified: mltonlib/trunk/com/ssh/prettier/unstable/detail/prettier.sml
===================================================================
--- mltonlib/trunk/com/ssh/prettier/unstable/detail/prettier.sml 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/prettier/unstable/detail/prettier.sml 2007-09-02 23:29:10 UTC (rev 5997)
@@ -9,6 +9,7 @@
open TopLevel
infix 4 <\
infixr 2 |<
+ infix >>=
(* SML/NJ workaround --> *)
structure C = Char and S = String and SS = Substring
@@ -31,10 +32,6 @@
| NESTING of Int.t -> t
withtype t = t' Lazy.t
- datatype elem =
- STRING of String.t
- | NEWLINE of Int.t
-
val lazy = L
val empty = E EMPTY
@@ -46,7 +43,7 @@
local
fun assertAllPrint str =
if S.all C.isPrint str then ()
- else fail "unprintable characters given to Prettier.txt"
+ else fail "Unprintable characters given to Prettier.txt"
in
val txt' = E o TEXT
val txt = txt' o Effect.obs assertAllPrint
@@ -70,11 +67,11 @@
val op <^> = E o JOIN
fun punctuate sep =
- fn [] => []
- | d::ds => let
+ fn [] => []
+ | d::ds => let
fun lp rs d1 =
- fn [] => List.revAppend (rs, [d1])
- | d2::ds => lp (d1 <^> sep::rs) d2 ds
+ fn [] => List.revAppend (rs, [d1])
+ | d2::ds => lp (d1 <^> sep::rs) d2 ds
in
lp [] d ds
end
@@ -100,23 +97,15 @@
local
fun flatten doc =
L (fn () =>
- case F doc of
- EMPTY =>
- doc
- | JOIN (lhs, rhs) =>
- E (JOIN (flatten lhs, flatten rhs))
- | NEST (cols, doc) =>
- E (NEST (cols, flatten doc))
- | TEXT _ =>
- doc
- | LINE b =>
- if b then empty else space
- | CHOICE {wide, ...} =>
- wide
- | COLUMN f =>
- E (COLUMN (flatten o f))
- | NESTING f =>
- E (NESTING (flatten o f)))
+ case F doc
+ of EMPTY => doc
+ | JOIN (lhs, rhs) => E (JOIN (flatten lhs, flatten rhs))
+ | NEST (cols, doc) => E (NEST (cols, flatten doc))
+ | TEXT _ => doc
+ | LINE b => if b then empty else space
+ | CHOICE {wide, ...} => wide
+ | COLUMN f => E (COLUMN (flatten o f))
+ | NESTING f => E (NESTING (flatten o f)))
in
fun choice {wide, narrow} =
E (CHOICE {wide = flatten wide, narrow = narrow})
@@ -139,10 +128,9 @@
local
fun mk bop xs =
- case rev xs of
- [] => empty
- | x::xs =>
- foldl bop x xs
+ case rev xs
+ of [] => empty
+ | x::xs => foldl bop x xs
in
val hsep = mk op <+>
val vsep = mk op <$>
@@ -163,70 +151,65 @@
val braces = enclose braces
val brackets = enclose brackets
- fun fold f s maxCols doc = let
+ fun renderer maxCols w doc = let
+ open IOSMonad
+
datatype t' =
NIL
| PRINT of String.t * t
| LINEFEED of Int.t * t
withtype t = t' Lazy.t
- fun layout s doc =
- case F doc of
- NIL => s
- | PRINT (str, doc) =>
- layout (f (STRING str, s)) doc
- | LINEFEED (cols, doc) =>
- layout (f (NEWLINE cols, s)) doc
+ fun layout doc =
+ case F doc
+ of NIL => return ()
+ | PRINT (str, doc) => w str >>= (fn () => layout doc)
+ | LINEFEED (cols, doc) => w "\n" >>= (fn () =>
+ w (spaces cols) >>= (fn () =>
+ layout doc))
fun fits usedCols doc =
NONE = maxCols orelse
usedCols <= valOf maxCols andalso
- case F doc of
- NIL => true
- | LINEFEED _ => true
- | PRINT (str, doc) =>
- fits (usedCols + size str) doc
+ case F doc
+ of NIL => true
+ | LINEFEED _ => true
+ | PRINT (str, doc) => fits (usedCols + size str) doc
fun best usedCols work =
L (fn () =>
- case work of
- [] => E NIL
- | (nestCols, doc)::rest =>
- case F doc of
- EMPTY =>
- best usedCols rest
- | JOIN (lhs, rhs) =>
- best usedCols ((nestCols, lhs)::
- (nestCols, rhs)::rest)
- | NEST (cols, doc) =>
- best usedCols ((nestCols + cols, doc)::rest)
- | TEXT str =>
- E (PRINT (str, best (usedCols + size str) rest))
- | LINE _ =>
- E (LINEFEED (nestCols, best nestCols rest))
- | CHOICE {wide, narrow} => let
- val wide = best usedCols ((nestCols, wide)::rest)
- in
- if fits usedCols wide then
- wide
- else
- best usedCols ((nestCols, narrow)::rest)
- end
- | COLUMN f =>
- best usedCols ((nestCols, f usedCols)::rest)
- | NESTING f =>
- best usedCols ((nestCols, f nestCols)::rest))
+ case work
+ of [] => E NIL
+ | (nestCols, doc)::rest =>
+ case F doc
+ of EMPTY =>
+ best usedCols rest
+ | JOIN (lhs, rhs) =>
+ best usedCols ((nestCols, lhs)::(nestCols, rhs)::rest)
+ | NEST (cols, doc) =>
+ best usedCols ((nestCols + cols, doc)::rest)
+ | TEXT str =>
+ E (PRINT (str, best (usedCols + size str) rest))
+ | LINE _ =>
+ E (LINEFEED (nestCols, best nestCols rest))
+ | CHOICE {wide, narrow} => let
+ val wide = best usedCols ((nestCols, wide)::rest)
+ in
+ if fits usedCols wide
+ then wide
+ else best usedCols ((nestCols, narrow)::rest)
+ end
+ | COLUMN f =>
+ best usedCols ((nestCols, f usedCols)::rest)
+ | NESTING f =>
+ best usedCols ((nestCols, f nestCols)::rest))
in
- layout s (best 0 [(0, doc)])
+ layout (best 0 [(0, doc)])
end
- fun app e = fold (e o #1) ()
+ fun render maxCols doc =
+ concat o rev o #2 |< renderer maxCols (IOSMonad.fromWriter op ::) doc []
- fun pretty n d =
- concat o rev |< fold (fn (STRING s, ss) => s::ss
- | (NEWLINE n, ss) =>
- spaces n::"\n"::ss) [] n d
-
local
val join =
fn [] => empty
@@ -246,12 +229,7 @@
SS.full
end
- fun println os n d =
- (app (fn STRING s => TextIO.output (os, s)
- | NEWLINE n =>
- (TextIO.output1 (os, #"\n")
- ; repeat (fn () => TextIO.output1 (os, #" ")) n ()))
- n d
- ; TextIO.output1 (os, #"\n")
- ; TextIO.flushOut os)
+ fun println c d =
+ (ignore (renderer c (IOSMonad.fromPutter TextIO.output) d TextIO.stdOut)
+ ; print "\n")
end
Modified: mltonlib/trunk/com/ssh/prettier/unstable/public/prettier.sig
===================================================================
--- mltonlib/trunk/com/ssh/prettier/unstable/public/prettier.sig 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/prettier/unstable/public/prettier.sig 2007-09-02 23:29:10 UTC (rev 5997)
@@ -25,30 +25,18 @@
type t
(** The abstract type of documents. *)
- datatype elem =
- STRING of String.t
- | NEWLINE of Int.t
+ val renderer : Int.t Option.t -> (String.t -> (Unit.t, 's) IOSMonad.t)
+ -> (t -> (Unit.t, 's) IOSMonad.t)
+ (** Function for linearizing a document directly to a given stream. *)
- val fold : (elem * 'a -> 'a) -> 'a -> Int.t Option.t -> t -> 'a
- (**
- * Linearizes the given document and folds the linearized document with
- * the given function.
- *)
+ val render : Int.t Option.t -> t -> String.t
+ (** Renders the document as a string. *)
- val app : elem Effect.t -> Int.t Option.t -> t Effect.t
- (** {app e = fold (e o #1) ()} *)
+ val println : Int.t Option.t -> t Effect.t
+ (** Writes the document to stdOut with a newline and flushes stdOut. *)
- val pretty : Int.t Option.t -> t -> String.t
- (** {pretty n d = concat (rev (fold op:: [] n d))} *)
+ (** == Basic Combinators == *)
- val println : TextIO.outstream -> Int.t Option.t -> t Effect.t
- (**
- * Writes the document to the specified stream with a newline and
- * flushes the stream.
- *)
-
- (** == BASIC COMBINATORS == *)
-
val empty : t
(** The empty document is semantically equivalent to {txt ""}. *)
@@ -143,7 +131,7 @@
* like {line}.
*)
- (** == ALIGNMENT COMBINATORS == *)
+ (** == Alignment Combinators == *)
val column : (Int.t -> t) -> t
val nesting : (Int.t -> t) -> t
@@ -157,7 +145,7 @@
val fillBreak : Int.t -> t UnOp.t
val fill : Int.t -> t UnOp.t
- (** == OPERATORS == *)
+ (** == Operators == *)
val <+> : t BinOp.t (** Concatenates with a {space}. *)
val <$> : t BinOp.t (** Concatenates with a {line}. *)
@@ -165,7 +153,7 @@
val <$$> : t BinOp.t (** Concatenates with a {linebreak}. *)
val <//> : t BinOp.t (** Concatenates with a {softbreak}. *)
- (** == LIST COMBINATORS == *)
+ (** == List Combinators == *)
val sep : t List.t -> t (** {sep = group o vsep} *)
val cat : t List.t -> t (** {cat = group o vcat} *)
@@ -183,7 +171,7 @@
val vcat : t List.t -> t (** Concatenates with {<$$>}. *)
val fillCat : t List.t -> t (** Concatenates with {<//>}. *)
- (** == BRACKETING COMBINATORS == *)
+ (** == Bracketing Combinators == *)
val enclose : t Sq.t -> t UnOp.t
(** {enclose (l, r) d = l <^> d <^> r} *)
@@ -195,7 +183,7 @@
val braces : t UnOp.t (** {braces = enclose (lbrace, rbrace)} *)
val brackets : t UnOp.t (** {brackets = enclose (lbracket, rbracket)} *)
- (** == CHARACTER DOCUMENTS == *)
+ (** == Character Documents == *)
val lparen : t (** {txt "("} *)
val rparen : t (** {txt ")"} *)
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-02 16:13:56 UTC (rev 5996)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-02 23:29:10 UTC (rev 5997)
@@ -27,26 +27,26 @@
val bool = bool
val eq = eq
val exn = exn
- val layout = layout
+ val pretty = pretty
end
local
open Prettier
in
val indent = nest 2 o sep
- fun named t n v = str n <^> nest 2 (line <^> layout t v)
+ fun named t n v = str n <^> nest 2 (line <^> pretty t v)
val comma = comma
val dot = dot
val group = group
val op <^> = op <^>
- val pretty = pretty
+ val render = render
local
open Maybe
val I = I.fromString
val cols = Monad.sum [S"-w"@`I, L"--width"@`I, E"COLUMNS"@`I, `70]
in
- val println = println TextIO.stdOut (get cols)
+ val println = println (get cols)
end
val punctuate = punctuate
@@ -264,5 +264,5 @@
fun trivial b = classify (if b then SOME "trivial" else NONE)
fun collect t v p =
- G.Monad.map (fn (r, ts, msg) => (r, pretty NONE (layout t v)::ts, msg)) p
+ G.Monad.map (fn (r, ts, msg) => (r, render NONE (pretty t v)::ts, msg)) p
end
More information about the MLton-commit
mailing list