ikarus/lab/pretty-print.ss

616 lines
20 KiB
Scheme

;;; Copied From CSUG7:
;;; procedure: (pretty-format sym)
;;; returns: see below
;;; procedure: (pretty-format sym fmt)
;;; returns: unspecified
;;; By default, the pretty printer uses a generic algorithm for printing
;;; each form. This procedure is used to override this default and guide
;;; the pretty-printers treatment of specific forms. The symbol sym
;;; names a syntactic form or procedure. With just one argument,
;;; pretty-format returns the current format associated with sym, or #f
;;; if no format is associated with sym.
;;; In the two-argument case, the format fmt is associated with sym for
;;; future invocations of the pretty printer. fmt must be in the
;;; formatting language described below.
;;; <fmt> ::= (quote symbol)
;;; | var
;;; | symbol
;;; | (read-macro string symbol)
;;; | (meta)
;;; | (bracket . fmt-tail)
;;; | (alt fmt fmt*)
;;; | fmt-tail
;;; fmt-tail ::= ()
;;; | (tab fmt ...)
;;; | (fmt tab ...)
;;; | (tab fmt . fmt-tail)
;;; | (fmt ...)
;;; | (fmt . fmt-tail)
;;; | (fill tab fmt ...)
;;; tab ::= int
;;; | #f
;;; Some of the format forms are used for matching when there are
;;; multiple alternatives, while others are used for matching and
;;; control indentation or printing. A description of each fmt is given
;;; below.
;;; (quote symbol):
;;; This matches only the symbol symbol.
;;; var:
;;; This matches any symbol.
;;; symbol:
;;; This matches any input.
;;; (read-macro string symbol):
;;; This is used for read macros like quote and syntax. It matches any
;;; input of the form (symbol subform). For forms that match, the pretty
;;; printer prints string immediately followed by subform.
;;; (meta):
;;; This is a special case used for the meta keyword (Section 10.7)
;;; which is used as a keyword prefix of another form.
;;; (alt fmt fmt*):
;;; This compares the input against the specified formats and uses the
;;; one that is the closest match. Most often, one of the formats will
;;; match exactly, but in other cases, as when input is malformed or
;;; appears in abstract form in the template of a syntactic abstraction,
;;; none of the formats will match exactly.
;;; (bracket . fmt-tail):
;;; This matches any list-structured input and prints the input enclosed
;;; in square brackets, i.e., [ and ], rather than parentheses.
;;; fmt-tail:
;;; This matches any list-structured input. Indentation of
;;; list-structured forms is determined via the fmt-tail specifier used
;;; to the last two cases above. A description of each fmt-tail is given
;;; below.
;;; ():
;;; This matches an empty list tail.
;;; (tab fmt ...):
;;; This matches the tail of any proper list; if the tail is nonempty
;;; and the list does not fit entirely on the current line, a line break
;;; is inserted before the first subform of the tail and tab (see below)
;;; determines the amount by which this and all subsequent subforms are
;;; indented.
;;; (fmt tab ...):
;;; This matches the tail of any proper list; if the tail is nonempty
;;; and the list does not fit entirely on the current line, a line break
;;; is inserted after the first subform of the tail and tab (see below)
;;; determines the amount by which all subsequent subforms are indented.
;;; (tab fmt . fmt-tail):
;;; This matches a nonempty tail if the tail of the tail matches
;;; fmt-tail. If the list does not fit entirely on the current line, a
;;; line break is inserted before the first subform of the tail and tab
;;; (see below) determines the amount by which the subform is indented.
;;; (fmt ...):
;;; This matches the tail of any proper list and specified that no line
;;; breaks are to be inserted before or after the current or subsequent
;;; subforms.
;;; (fmt . fmt-tail):
;;; This matches a nonempty tail if the tail of the tail matches
;;; fmt-tail and specifies that no line break is to be inserted before
;;; or after the current subform.
;;; (fill tab fmt ...):
;;; This matches the tail of any proper list and invokes a fill mode in
;;; which the forms are packed with as many as will fit on each line. A
;;; tab determines the amount by which a list subform is indented. If
;;; tab is a nonnegative exact integer int, the subform is indented int
;;; spaces in from the character position just after the opening
;;; parenthesis or bracket of the parent form. If tab is #f, the
;;; standard indentation is used. The standard indentation can be
;;; determined or changed via the parameter pretty-standard-indent,
;;; which is described later in this section.
;;; In cases where a format is given that doesn't quite match, the
;;; pretty printer tries to use the given format as far as it can. For
;;; example, if a format matches a list-structured form with a specific
;;; number of subforms, but more or fewer subform are given, the pretty
;;; printer will discard or replicate subform formats as necessary.
;;; Here is an example showing the formatting of let might be specified.
;;; (pretty-format 'let
;;; '(alt (let ([bracket var x] 0 ...) #f e #f e ...)
;;; (let var ([bracket var x] 0 ...) #f e #f e ...)))
;;; Since let comes in two forms, named and unnamed, two alternatives
;;; are specified. In either case, the bracket fmt is used to enclose
;;; the bindings in square brackets, with all bindings after the first
;;; appearing just below the first (and just after the enclosing opening
;;; parenthesis), if they don't all fit on one line. Each body form is
;;; indented by the standard indentation.
;;; parameter: pretty-line-length
;;; parameter: pretty-one-line-limit
;;; The value of each of these parameters must be a positive fixnum.
;;; The parameters pretty-line-length and pretty-one-line-limit control
;;; the output produced by pretty-print. pretty-line-length determines
;;; after which character position (starting from the first) on a line
;;; the pretty printer attempts to cut off output. This is a soft limit
;;; only; if necessary, the pretty-printer will go beyond
;;; pretty-line-length.
;;; pretty-one-line-limit is similar to pretty-line-length, except that
;;; it is relative to the first nonblank position on each line of
;;; output. It is also a soft limit.
;;; parameter: pretty-initial-indent
;;; The value of this parameter must be a nonnegative fixnum.
;;; The parameter pretty-initial-indent is used to tell pretty-print
;;; where on an output line it has been called. If pretty-initial-indent
;;; is zero (the default), pretty-print assumes that the first line of
;;; output it produces will start at the beginning of the line. If set
;;; to a nonzero value n, pretty-print assumes that the first line will
;;; appear at character position n and will adjust its printing of
;;; subsequent lines.
;;; parameter: pretty-standard-indent
;;; The value of this parameter must be a nonnegative fixnum.
;;; This determines the amount by which pretty-print indents
;;; subexpressions of most forms, such as let expressions, from the
;;; form's keyword or first subexpression.
;;; parameter: pretty-maximum-lines
;;; The parameter pretty-maximum-lines controls how many lines
;;; pretty-print prints when it is called. If set to #f (the default),
;;; no limit is imposed; if set to a nonnegative fixnum n, at most n
;;; lines are printed.
(let ()
(begin ;;; symbol printing helpers
(define initial?
(lambda (c)
(or (letter? c) (special-initial? c))))
(define letter?
(lambda (c)
(or (and ($char<= #\a c) ($char<= c #\z))
(and ($char<= #\A c) ($char<= c #\Z)))))
(define digit?
(lambda (c)
(and ($char<= #\0 c) ($char<= c #\9))))
(define special-initial?
(lambda (x)
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
(define subsequent?
(lambda (x)
(or (initial? x)
(digit? x)
(special-subsequent? x))))
(define special-subsequent?
(lambda (x)
(memq x '(#\+ #\- #\. #\@))))
(define subsequent*?
(lambda (str i n)
(or ($fx= i n)
(and (subsequent? ($string-ref str i))
(subsequent*? str ($fxadd1 i) n)))))
(define valid-symbol-string?
(lambda (str)
(or (let ([n ($string-length str)])
(and ($fx>= n 1)
(initial? ($string-ref str 0))
(subsequent*? str 1 n)))
(string=? str "+")
(string=? str "-")
(string=? str "..."))))
(define write-symbol-esc-loop
(lambda (x i n p)
(unless ($fx= i n)
(let ([c ($string-ref x i)])
(when (memq c '(#\\ #\|))
(write-char #\\ p))
(write-char c p))
(write-symbol-esc-loop x ($fxadd1 i) n p))))
(define write-symbol-esc
(lambda (x p)
(write-char #\| p)
(write-symbol-esc-loop x 0 ($string-length x) p)
(write-char #\| p)))
(define write-symbol
(lambda (x p)
(let ([str (symbol->string x)])
(if (valid-symbol-string? str)
(write-char* str p)
(write-symbol-esc str p))))))
(define (symbol-output symbol) ;-> var output box
(define (symbol-output-length str esc?)
(define (subs s n i)
(cond
[(fx= i n) n]
[(subsequent? (string-ref s i))
(subs s n (fxadd1 i))]
[else
(esc s n i i)]))
(define (esc s n i len)
(cond
[(fx= i n) (fx+ len 2)] ; for the bars
[(memv (string-ref s i) '(#\\ #\|))
(esc s n (fx+ i 1) (fx+ len 2))] ;;; for \ escape
[else
(esc s n (fx+ i 1) (fx+ len 1))]))
(define (init s n)
(cond
[(fx= n 0) 2] ; ||
[else
(case (string-ref s 0)
[(#\+ #\-)
(if (fx= n 1)
1
(esc s n 1 1))]
[(#\.)
(if (and (fx= n 3)
(char=? (string-ref s 1) #\.)
(char=? (string-ref s 2) #\.))
3
(esc s n 1 1))]
[else
(if (initial? (string-ref s 0))
(subs s n 1)
(esc s n 1 1))])]))
(if esc?
(esc str (string-length str) 0 0)
(init str (string-length str))))
(if (gensym? symbol)
`#(var ,symbol
,(symbol-output-length (gensym->string symbol) #f)
,(symbol-output-length (gensym->unique-string symbol) #t))
`#(var ,symbol
,(symbol-output-length (symbol->string symbol) #f))))
(define (number-output number) ; -> string
(number->string number))
(define (char-output char) ; -> string
(let ([i (char->integer char)])
(cond
[(fx< i (vector-length char-table))
(string-append "#\\" (vector-ref char-table i))]
[(fx< i 127)
(string-append "#\\" (string char))]
[(fx= i 127) "#\\del"]
[else (string-append "#\\+" (number->string i))])))
(define char-table ; first nonprintable chars
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
(define (string-output str) ; -> string | append
(define (f s n i len)
(cond
[(fx= i n) len]
[(memv (string-ref s i) '(#\newline #\" #\\ #\tab #\return))
(f s n (fxadd1 i) (fx+ len 2))]
[else
(f s n (fxadd1 i) (fxadd1 len))]))
(let ([n (string-length str)])
(let ([m (f str (string-length str) 0 0)])
(if (fx= n m)
`#(append "\"" ,str "\"")
`#(string ,m ,str)))))
(define (make-output x h i) ;-> output, i
(cond
[(or (pair? x) (vector? x))
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(cond
[(fx< n 0) ;;; shared and already printed
(values (ref-output n) i)]
[(fx= n 0) ;;; not shared
(if (pair? x)
(pair-output x h i)
(vector-output x h i))]
[else ;;; shared and this is the first ref
(let ([i (fx- i 1)])
(put-hash-table! h x i)
(let-values ([(no ni)
(if (pair? x)
(pair-output x h i)
(vector-output x h i))])
(values `#(append ,(mark-output i) ,no) ni)))]))]
[else
(if (pair? x)
(pair-output x h i)
(vector-output x h i))])]
[(symbol? x) (values (symbol-output x) i)]
[(number? x) (values (number-output x) i)]
[(char? x) (values (char-output x) i)]
[(boolean? x) (values (if x "#t" "#f") i)]
[(null? x) (values "()" i)]
[(eq? x (void)) (values "#<void>" i)]
[(eof-object? x) (values "#!eof" i)]
[(bwp-object? x) (values "#!bwp" i)]
[(hash-table? x) (values "#<hash-table>" i)]
[($unbound-object? x) (values "#<unbound-object>" i)]
[($forward-ptr? x) (values "#<forward-pointer>" i)]
[else (values "#<unknown>" i)]))
(define (vector-output x h i)
(let* ([n (vector-length x)]
[v (make-vector n)])
(let f ([idx 0] [i i])
(cond
[(fx= idx n)
(values `#(vector ,v) i)]
[else
(let-values ([(o i)
(make-output (vector-ref x idx) i)])
(vector-set! v idx o)
(f (fxadd1 idx) i))]))))
(define (make-pair-output x h i)
;;; first cut, assume no special formatting
(errrrrrrrrrrrrrr))
(define write-list
(lambda (x p h i)
(cond
[(and (pair? x)
(or (not (get-hash-table h x #f))
(fxzero? (get-hash-table h x 0))))
(write-char #\space p)
(write-list (cdr x) p h
(writer (car x) p h i))]
[(null? x) i]
[else
(write-char #\space p)
(write-char #\. p)
(write-char #\space p)
(writer x p h i)])))
(define write-vector
(lambda (x p h i)
(write-char #\# p)
(write-char #\( p)
(let ([n (vector-length x)])
(let ([i
(cond
[(fx> n 0)
(let f ([idx 1] [i (writer (vector-ref x 0) p h i)])
(cond
[(fx= idx n)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (vector-ref x idx) p h i))]))]
[else i])])
(write-char #\) p)
i))))
(define write-record
(lambda (x p h i)
(write-char #\# p)
(write-char #\[ p)
(let ([i (writer (record-name x) p h i)])
(let ([n (record-length x)])
(let f ([idx 0] [i i])
(cond
[(fx= idx n)
(write-char #\] p)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (record-ref x idx) p h i))]))))))
(define macro
(lambda (x)
(define macro-forms
'([quote . "'"]
[quasiquote . "`"]
[unquote . ","]
[unquote-splicing . ",@"]
[syntax . "#'"]
[|#primitive| . "#%"]))
(and (pair? x)
(let ([d ($cdr x)])
(and (pair? d)
(null? ($cdr d))))
(assq ($car x) macro-forms))))
(define write-pair
(lambda (x p h i)
(write-char #\( p)
(let ([i (writer (car x) p h i)])
(let ([i (write-list (cdr x) p h i)])
(write-char #\) p)
i))))
(define write-ref
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\# p)))
(define write-mark
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\= p)))
(define writer
(lambda (x p h i)
(cond
[(pair? x)
(pretty-pair x p h i)]
[(symbol? x)
(if (gensym? x)
(write-gensym x p h i)
(begin (write-symbol x p) i))]
[(fixnum? x)
(write-fixnum x p)
i]
[(string? x)
(write-string x p)
i]
[(boolean? x)
(write-char* (if x "#t" "#f") p)
i]
[(char? x)
(write-character x p)
i]
[(procedure? x)
(write-char* "#<procedure>" p)
i]
[(output-port? x)
(write-char* "#<output-port " p)
(let ([i (writer (output-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(input-port? x)
(write-char* "#<input-port " p)
(let ([i (writer (input-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(vector? x)
(write-shareable x p h i write-vector)]
[(null? x)
(write-char #\( p)
(write-char #\) p)
i]
[(eq? x (void))
(write-char* "#<void>" p)
i]
[(eof-object? x)
(write-char* "#!eof" p)
i]
[(bwp-object? x)
(write-char* "#!bwp" p)
i]
[(record? x)
(let ([printer (record-printer x)])
(if (procedure? printer)
(begin (printer x p) i)
(write-shareable x p h i write-record)))]
[(hash-table? x)
(write-char* "#<hash-table>" p)
i]
[($unbound-object? x)
(write-char* "#<unbound-object>" p)
i]
[($forward-ptr? x)
(write-char* "#<forward-ptr>" p)
i]
[(number? x)
(write-char* (number->string x) p)
i]
[else
(write-char* "#<unknown>" p)
i])))
(define (hasher x h)
(define (vec-graph x i j h)
(unless (fx= i j)
(graph (vector-ref x i) h)
(vec-graph x (fxadd1 i) j h)))
(define (vec-dynamic x i j h)
(unless (fx= i j)
(dynamic (vector-ref x i) h)
(vec-dynamic x (fxadd1 i) j h)))
(define (graph x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(graph (car x) h)
(graph (cdr x) h)])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-graph x 0 (vector-length x) h)])]
[(gensym? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))])]))
(define (dynamic x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(dynamic (car x) h)
(dynamic (cdr x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-dynamic x 0 (vector-length x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]))
(if (print-graph)
(graph x h)
(dynamic x h)))
(define (write x p)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p h 0))
(flush-output-port p))
(let ()
;;; <fmt> ::= (quote symbol)
;;; | var
;;; | symbol
;;; | (read-macro string symbol)
;;; | (meta)
;;; | (bracket . fmt-list)
;;; | (alt fmt fmt*)
;;; | fmt-list
;;; fmt-list ::= ()
;;; | (tab fmt ...)
;;; | (fmt tab ...)
;;; | (tab fmt . fmt-list)
;;; | (fmt ...)
;;; | (fmt . fmt-list)
;;; | (fill tab fmt ...)
;;; tab ::= int
;;; | #f
)
(pretty-format
'([letrec (_ ((x _) ...) #t _ _ ...)]
[let (_ x ([x _] 0 ...) #t _ _ ...)]
[cond (_ (or (_ 0 _) (_ '=> 0 _)) ...)]