[MLton-commit] r5039
Vesa Karvonen
vesak at mlton.org
Fri Jan 12 04:29:46 PST 2007
Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml 2007-01-12 12:29:27 UTC (rev 5038)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml 2007-01-12 12:29:42 UTC (rev 5039)
@@ -0,0 +1,463 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * A pretty-printing library. The design is primarily based on Philip
+ * Wadler's article ``A prettier printer''
+ *
+ * http://homepages.inf.ed.ac.uk/wadler/topics/language-design.html
+ *
+ * which is a redesign of John Hughes's pretty-printing library described
+ * in ``The Design of a Pretty-Printing Library''
+ *
+ * http://www.cs.chalmers.se/~rjmh/Papers/pretty.html
+ *
+ * Some of Daan Leijen's PPrint library
+ *
+ * http://www.cs.uu.nl/~daan/pprint.html
+ *
+ * has also been implemented.
+ *)
+
+structure Prettier :> sig
+ type t
+ (** The abstract type of documents. *)
+
+ datatype elem =
+ STRING of String.t
+ | NEWLINE of Int.t
+
+ 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 app : elem Effect.t -> Int.t Option.t -> t Effect.t
+ (** {app e = fold (e o #1) ()} *)
+
+ val pretty : Int.t Option.t -> t -> String.t
+ (** {pretty n d = concat (rev (fold op:: [] n d))} *)
+
+ 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 ""}. *)
+
+ val chr : Char.t -> t
+ (**
+ * {chr c} contains the character {c}. The character shouldn't be a
+ * newline.
+ *)
+
+ val txt : String.t -> t
+ (**
+ * {txt s} contains the string {s}. The string shouldn't contain any
+ * newline characters.
+ *)
+
+ val str : String.t -> t
+ (**
+ * Converts a simple preformatted string into a document. The idea is
+ * that newlines separate paragraphs and spaces after a newline specify
+ * indentation. Spaces inside paragraph are replaced by softlines,
+ * paragraphs are prefixed with a line, nested by the specified
+ * indentation level, and grouped. Everything is then concatenated
+ * together.
+ *)
+
+ val <^> : t BinOp.t
+ (**
+ * {l <^> r} is the concatenation of the documents {l} and {r}.
+ *
+ * Note: This is the same as the operator <> used in the original
+ * Haskell libraries. In SML, <> is already used.
+ *)
+
+ val nest : Int.t -> t UnOp.t
+ (**
+ * {nest n d} renders document {d} indented by {n} more columns.
+ *
+ * Note that in order for {nest} to have any effect, you must have line
+ * breaks in {group}s in {d}.
+ *)
+
+ val line : t
+ (**
+ * Advances to the next line and indents, unless undone by {group} in
+ * which case {line} behaves like {txt " "}.
+ *)
+
+ val linebreak : t
+ (**
+ * Advances to the next line and indents, unless undone by {group} in
+ * which case {linebreak} behaves like {empty}.
+ *)
+
+ val group : t UnOp.t
+ (**
+ * Used to specify alternative layouts. {group d} undoes all line
+ * breaks in document {d}. The resulting line of text is added to the
+ * current output line if it fits. Otherwise, the document is rendered
+ * without changes (with line breaks).
+ *)
+
+ val choice : {wide : t, narrow : t} -> t
+ (**
+ * Used to specify alternative documents. The wider document is added
+ * to the current output line if it fits. Otherwise, the narrow
+ * document is rendered.
+ *
+ * Warning: This operation allows one to create documents whose
+ * rendering may not produce optimal or easily predictable results.
+ *)
+
+ val lazy : t Thunk.t -> t
+ (**
+ * Creates a lazily computed document. {lazy (fn () => doc)} is
+ * equivalent to {doc} except that the expression {doc} may not be
+ * evaluated at all.
+ *
+ * Note: This is primarily useful for specifying the narrow alternative
+ * to {choice} - unless, of course, there is a chance that the whole
+ * document will not be rendered at all.
+ *)
+
+ val softline : t
+ (**
+ * Behaves like a space if the resulting output fits, otherwise behaves
+ * like {line}.
+ *)
+
+ val softbreak : t
+ (**
+ * Behaves like {empty} if the resulting output fits, otherwise behaves
+ * like {line}.
+ *)
+
+ (** == ALIGNMENT COMBINATORS == *)
+
+ val column : (Int.t -> t) -> t
+ val nesting : (Int.t -> t) -> t
+
+ val indent : Int.t -> t UnOp.t
+ val hang : Int.t -> t UnOp.t
+ val align : t UnOp.t
+
+ val width : (Int.t -> t) -> t UnOp.t
+
+ val fillBreak : Int.t -> t UnOp.t
+ val fill : Int.t -> t UnOp.t
+
+ (** == OPERATORS == *)
+
+ val <+> : t BinOp.t (** Concatenates with a {space}. *)
+ val <$> : t BinOp.t (** Concatenates with a {line}. *)
+ val </> : t BinOp.t (** Concatenates with a {softline}. *)
+ val <$$> : t BinOp.t (** Concatenates with a {linebreak}. *)
+ val <//> : t BinOp.t (** Concatenates with a {softbreak}. *)
+
+ (** == LIST COMBINATORS == *)
+
+ val sep : t List.t -> t (** {sep = group o vsep} *)
+ val cat : t List.t -> t (** {cat = group o vcat} *)
+
+ val punctuate : t -> t List.t UnOp.t
+ (**
+ * {punctuate sep docs} concatenates {sep} to the right of each
+ * document in {docs} except the last one.
+ *)
+
+ val hsep : t List.t -> t (** Concatenates with {<+>}. *)
+ val vsep : t List.t -> t (** Concatenates with {<$>}. *)
+ val fillSep : t List.t -> t (** Concatenates with {</>}. *)
+ val hcat : t List.t -> t (** Concatenates with {<^>}. *)
+ val vcat : t List.t -> t (** Concatenates with {<$$>}. *)
+ val fillCat : t List.t -> t (** Concatenates with {<//>}. *)
+
+ (** == BRACKETING COMBINATORS == *)
+
+ val enclose : t Sq.t -> t UnOp.t
+ (** {enclose (l, r) d = l <^> d <^> r} *)
+
+ val squotes : t UnOp.t (** {squotes = enclose (squote, squote)} *)
+ val dquotes : t UnOp.t (** {dquotes = enclose (dquote, dquote)} *)
+ val parens : t UnOp.t (** {parens = enclose (lparen, rparen)} *)
+ val angles : t UnOp.t (** {angles = enclose (langle, rangle)} *)
+ val braces : t UnOp.t (** {braces = enclose (lbrace, rbrace)} *)
+ val brackets : t UnOp.t (** {brackets = enclose (lbracket, rbracket)} *)
+
+ (** == CHARACTER DOCUMENTS == *)
+
+ val lparen : t (** {txt "("} *)
+ val rparen : t (** {txt ")"} *)
+ val langle : t (** {txt "<"} *)
+ val rangle : t (** {txt ">"} *)
+ val lbrace : t (** {txt "{"} *)
+ val rbrace : t (** {txt "}"} *)
+ val lbracket : t (** {txt "["} *)
+ val rbracket : t (** {txt "]"} *)
+ val squote : t (** {txt "'"} *)
+ val dquote : t (** {txt "\""} *)
+ val semi : t (** {txt ";"} *)
+ val colon : t (** {txt ":"} *)
+ val comma : t (** {txt ","} *)
+ val space : t (** {txt " "} *)
+ val dot : t (** {txt "."} *)
+ val backslash : t (** {txt "\\"} *)
+ val equals : t (** {txt "="} *)
+end = struct
+ structure Dbg = MkDbg (open DbgDefs val name = "Prettier")
+ and C = Char and S = String and SS = Substring and P = Promise
+
+ local
+ open P
+ in
+ val E = eager
+ val F = force
+ val L = lazy
+ end
+
+ datatype t' =
+ EMPTY
+ | LINE of bool
+ | JOIN of t Sq.t
+ | NEST of Int.t * t
+ | TEXT of String.t
+ | CHOICE of {wide : t, narrow : t}
+ | COLUMN of Int.t -> t
+ | NESTING of Int.t -> t
+ withtype t = t' P.t
+
+ datatype elem =
+ STRING of String.t
+ | NEWLINE of Int.t
+
+ val lazy = L
+
+ val empty = E EMPTY
+ val line = E (LINE false)
+ val linebreak = E (LINE true)
+ val column = E o COLUMN
+ val nesting = E o NESTING
+
+ local
+ fun assertAllPrint str =
+ Dbg.assert 0 (fn () => S.all C.isPrint str)
+ in
+ val txt' = E o TEXT
+ val txt = txt' o Effect.obs assertAllPrint
+ val chr = txt o str
+ end
+
+ val parens as (lparen, rparen) = (txt' "(", txt' ")")
+ val angles as (langle, rangle) = (txt' "<", txt' ">")
+ val braces as (lbrace, rbrace) = (txt' "{", txt' "}")
+ val brackets as (lbracket, rbracket) = (txt' "[", txt' "]")
+ val squote = txt' "'"
+ val dquote = txt' "\""
+ val semi = txt' ";"
+ val colon = txt' ":"
+ val comma = txt' ","
+ val space = txt' " "
+ val dot = txt' "."
+ val backslash = txt' "\\"
+ val equals = txt' "="
+
+ val op <^> = E o JOIN
+
+ fun punctuate sep =
+ fn [] => []
+ | d::ds => let
+ fun lp rs d1 =
+ fn [] => List.revAppend (rs, [d1])
+ | d2::ds => lp (d1 <^> sep::rs) d2 ds
+ in
+ lp [] d ds
+ end
+
+ fun nest n = E o n <\ NEST
+
+ fun spaces n = S.tabulate (n, const #" ")
+
+ fun align d = column (fn k => nesting (fn i => nest (k-i) d))
+ fun hang i d = align (nest i d)
+ fun indent i d = hang i (txt (spaces i) <^> d)
+
+ fun width f d = column (fn l => d <^> column (fn r => f (r-l)))
+
+ local
+ fun mk p t f =
+ width (fn w => if p (f, w) then t f else txt (spaces (f-w)))
+ in
+ val fillBreak = mk op < (flip nest linebreak)
+ val fill = mk op <= (const empty)
+ end
+
+ 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)))
+ in
+ fun choice {wide, narrow} =
+ E (CHOICE {wide = flatten wide, narrow = narrow})
+ fun group doc =
+ choice {wide = doc, narrow = doc}
+ end
+
+ val softline = group line
+ val softbreak = group linebreak
+
+ local
+ fun mk m (l, r) = l <^> m <^> r
+ in
+ val op <+> = mk space
+ val op <$> = mk line
+ val op </> = mk softline
+ val op <$$> = mk linebreak
+ val op <//> = mk softbreak
+ end
+
+ local
+ fun mk bop xs =
+ case rev xs of
+ [] => empty
+ | x::xs =>
+ foldl bop x xs
+ in
+ val hsep = mk op <+>
+ val vsep = mk op <$>
+ val fillSep = mk op </>
+ val hcat = mk op <^>
+ val vcat = mk op <$$>
+ val fillCat = mk op <//>
+ end
+
+ val sep = group o vsep
+ val cat = group o vcat
+
+ fun enclose (l, r) d = l <^> d <^> r
+ val squotes = enclose (Sq.mk squote)
+ val dquotes = enclose (Sq.mk dquote)
+ val parens = enclose parens
+ val angles = enclose angles
+ val braces = enclose braces
+ val brackets = enclose brackets
+
+ fun fold f s maxCols doc = let
+ datatype t' =
+ NIL
+ | PRINT of String.t * t
+ | LINEFEED of Int.t * t
+ withtype t = t' P.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 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
+
+ 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))
+ in
+ layout s (best 0 [(0, doc)])
+ end
+
+ fun app e = fold (e o #1) ()
+
+ 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
+ | (_, d)::xs =>
+ group d <^> hcat (map (group o uncurry nest o
+ Pair.map (id, line <\ op <^>)) xs)
+ in
+ val str =
+ join o
+ map (Pair.map (SS.size,
+ fillSep o
+ map (txt' o SS.string) o
+ SS.fields C.isSpace) o
+ SS.splitl C.isSpace) o
+ SS.fields (#"\n" <\ op =) o
+ SS.dropl C.isSpace o
+ 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)
+end
Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list