801 lines
30 KiB
Scheme
801 lines
30 KiB
Scheme
;;; pretty.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;;; TODO
|
|
|
|
;;; support enough power to describe generic as a pattern?
|
|
;;; retain external comments in pretty-file?
|
|
|
|
;;; $make-graph-env and $last-new-vector-element are from print.ss
|
|
|
|
;;;; EXPORTED VARIABLES
|
|
|
|
;;; pretty tries to fit things within line length
|
|
(begin
|
|
(define pretty-line-length
|
|
($make-thread-parameter
|
|
75
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx> x 0))
|
|
($oops 'pretty-line-length "~s is not a positive fixnum" x))
|
|
x)))
|
|
|
|
;;; pretty tries to break things longer than one line limit
|
|
(define pretty-one-line-limit
|
|
($make-thread-parameter
|
|
60
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx> x 0))
|
|
($oops 'pretty-one-line-limit "~s is not a positive fixnum" x))
|
|
x)))
|
|
|
|
;;; initial indentation of first line; used to properly align subsequent
|
|
;;; lines
|
|
(define pretty-initial-indent
|
|
($make-thread-parameter
|
|
0
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx>= x 0))
|
|
($oops 'pretty-initial-indent "~s is not a nonnegative fixnum" x))
|
|
x)))
|
|
|
|
;;; standard indent
|
|
(define pretty-standard-indent
|
|
($make-thread-parameter
|
|
1
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fx>= x 0))
|
|
($oops 'pretty-standard-indent "~s is not a nonnegative fixnum" x))
|
|
x)))
|
|
|
|
(define pretty-maximum-lines
|
|
($make-thread-parameter
|
|
#f
|
|
(lambda (x)
|
|
(unless (or (not x) (and (fixnum? x) (fx>= x 0)))
|
|
($oops 'pretty-maximum-lines "~s is not a positive fixnum or #f" x))
|
|
x)))
|
|
|
|
(define pretty-print)
|
|
(define pretty-file)
|
|
(define pretty-format)
|
|
|
|
;;;; IMPLEMENTATION
|
|
|
|
(let ()
|
|
|
|
;;; supported formats:
|
|
|
|
;;; <fmt> -> (quote <symbol>)
|
|
;;; | var
|
|
;;; | <symbol>
|
|
;;; | (read-macro <string> <symbol>)
|
|
;;; | (meta)
|
|
;;; | (alt <fmt> <fmt>*)
|
|
;;; | (bracket . <fmt-tail>)
|
|
;;; | <fmt-tail>
|
|
;;; <fmt-tail> -> ()
|
|
;;; | (<tab> <fmt> ...)
|
|
;;; | (<fmt> <tab> ...)
|
|
;;; | (<tab> <fmt> . <fmt-tail>)
|
|
;;; | (<fmt> ...)
|
|
;;; | (<fmt> . <fmt-tail>)
|
|
;;; | (fill <tab> <fmt> ...)
|
|
;;; <tab> -> <int>
|
|
;;; | #f
|
|
|
|
(define (tab? x) (or (eq? x #f) (fixnum? x)))
|
|
(define (dots? x) (eq? x '...))
|
|
|
|
(define (fmt? x)
|
|
(define (fmt-tail? x)
|
|
(syntax-case x (fill)
|
|
[() #t]
|
|
[(fill tab x dots) (and (tab? #'tab) (dots? #'dots) (fmt? #'x))]
|
|
[(tab x dots) (and (tab? #'tab) (dots? #'dots)) (fmt? #'x)]
|
|
[(x tab dots) (and (tab? #'tab) (dots? #'dots)) (fmt? #'x)]
|
|
[(tab x . t) (tab? #'tab) (and (fmt? #'x) (fmt-tail? #'t))]
|
|
[(x dots) (dots? #'dots) (fmt? #'x)]
|
|
[(x . t) (and (fmt? #'x) (fmt-tail? #'t))]
|
|
[_ #f]))
|
|
(syntax-case x (quote var read-macro meta alt bracket)
|
|
[(quote sym) (symbol? #'sym)]
|
|
[var #t]
|
|
[sym (and (symbol? #'sym) (not (dots? #'sym)) (not (eq? #'sym 'fill))) #t]
|
|
[(read-macro str sym) (and (string? #'str) (symbol? #'sym))]
|
|
[(meta) #t]
|
|
[(alt . x*) (and (list? #'x*) (not (null? #'x*)) (andmap fmt? #'x*))]
|
|
[(bracket . x) (fmt-tail? #'x)]
|
|
[x (fmt-tail? #'x)]))
|
|
|
|
(define (score-fmt fmt expr) ; lower is better, zero is best
|
|
(define (score-fmt-tail fmt-tail expr s)
|
|
(define (score-rest fmt expr s)
|
|
(if (list? expr)
|
|
(let ([s (fl/ s (fixnum->flonum (fx+ (length expr) 1)))])
|
|
(apply fl+ (map (lambda (expr) (score-fmt fmt expr s)) expr)))
|
|
s))
|
|
(syntax-case fmt-tail (fill)
|
|
[() (if (null? expr) 0.0 s)]
|
|
[(fill tab fmt dots) (score-rest #'fmt expr s)]
|
|
[(tab fmt dots) (and (tab? #'tab) (dots? #'dots)) (score-rest #'fmt expr s)]
|
|
[(fmt tab dots) (and (tab? #'tab) (dots? #'dots)) (score-rest #'fmt expr s)]
|
|
[(tab fmt . fmt-tail)
|
|
(tab? #'tab)
|
|
(if (pair? expr)
|
|
(let ([s (fl/ s 3.0)])
|
|
(fl+ (score-fmt #'fmt (car expr) s)
|
|
(score-fmt #'fmt-tail (cdr expr) s)))
|
|
s)]
|
|
[(fmt dots) (dots? #'dots) (score-rest #'fmt expr s)]
|
|
[(fmt . fmt-tail)
|
|
(if (pair? expr)
|
|
(let ([s (fl/ s 3.0)])
|
|
(fl+ (score-fmt #'fmt (car expr) s)
|
|
(score-fmt #'fmt-tail (cdr expr) s)))
|
|
s)]))
|
|
(define (score-fmt fmt expr s)
|
|
(syntax-case fmt (quote var read-macro meta alt bracket s)
|
|
[(quote sym) (if (eq? expr #'sym) 0.0 s)]
|
|
[var (if (symbol? expr) 0.0 s)]
|
|
[sym (symbol? #'sym) 0.0]
|
|
[(read-macro str sym)
|
|
(syntax-case expr ($primitive)
|
|
[(_ x) 0.0]
|
|
[($primitive n x) (if (memq #'n '(2 3)) 0.0 s)]
|
|
[else s])]
|
|
[(meta)
|
|
(syntax-case expr (meta)
|
|
[(meta . x) 0.0]
|
|
[else s])]
|
|
[(alt . fmt*)
|
|
(let f ([fmt* (cdr #'fmt*)] [min-s (score-fmt (car #'fmt*) expr s)])
|
|
(if (or (null? fmt*) (fl= min-s 0.0))
|
|
min-s
|
|
(f (cdr fmt*) (min (score-fmt (car fmt*) expr s) min-s))))]
|
|
[(bracket . fmt-tail) (score-fmt-tail #'fmt-tail expr s)]
|
|
[fmt-tail (score-fmt-tail #'fmt-tail expr s)]))
|
|
(score-fmt fmt expr 1.0))
|
|
|
|
(define (select-alt-fmt fmt expr)
|
|
(cond
|
|
[(syntax-case fmt (alt)
|
|
[(alt . fmt*) #'fmt*]
|
|
[_ #f]) =>
|
|
(lambda (fmt*)
|
|
(let ([fmt (car fmt*)])
|
|
(let f ([fmt* (cdr fmt*)] [min-s (score-fmt fmt expr)] [min-fmt fmt])
|
|
(if (or (null? fmt*) (fl= min-s 0.0))
|
|
(select-alt-fmt min-fmt expr)
|
|
(let* ([fmt (car fmt*)] [s (score-fmt fmt expr)])
|
|
(if (fl< s min-s)
|
|
(f (cdr fmt*) s fmt)
|
|
(f (cdr fmt*) min-s min-fmt)))))))]
|
|
[else fmt]))
|
|
|
|
(define-syntax decr
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ x) (identifier? #'x) #'(and x (fx- x 1))))))
|
|
|
|
(define-syntax limit?
|
|
(syntax-rules ()
|
|
((_ x) (eq? x 0))))
|
|
|
|
(define-record-type prty
|
|
(fields (mutable fmt) (mutable len) (mutable obj))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(define-threaded si) ; standard indent
|
|
(define-threaded lines) ; max number of lines to print
|
|
(define-threaded col)
|
|
(define-threaded room)
|
|
(define-threaded port)
|
|
(define-threaded pretty-string-output-port)
|
|
(define-threaded graph-env)
|
|
(define lparen #\() ;)( make paren bouncer happy
|
|
(define rparen #\))
|
|
(define lbrack #\[) ;][ make paren bouncer happy
|
|
(define rbrack #\])
|
|
|
|
(define check-line-maximum
|
|
(lambda ()
|
|
(when lines
|
|
(if (= lines 0)
|
|
($oops 'pretty-print "maximum-lines parameter exceeded")
|
|
(set! lines (- lines 1))))))
|
|
|
|
(define tab-amount
|
|
(lambda (x)
|
|
(if (and (integer? x) (nonnegative? x))
|
|
x
|
|
(if (eq? x #f)
|
|
si
|
|
#f))))
|
|
|
|
(define mk-prty
|
|
(lambda (x lev len fmt)
|
|
(let ([a (and graph-env (graph-env 'tag x))])
|
|
(if (not a)
|
|
(mk-prty-help x lev len fmt)
|
|
(record-case a
|
|
[(mark) n
|
|
(let ([s (format "#~d=" n)]
|
|
[r (mk-prty-help x lev len fmt)])
|
|
(make-prty `(read-macro ,s x)
|
|
(+ (string-length s) (prty-len r))
|
|
r))]
|
|
[(ref) n
|
|
(let ([s (format "#~d#" n)])
|
|
(make-prty 'x (string-length s) s))])))))
|
|
|
|
(define mk-prty-help
|
|
(lambda (x lev len fmt)
|
|
(define (get-pretty-format x)
|
|
(let ([fmt (and (symbol? (car x)) (pretty-format (car x)))])
|
|
(and fmt (select-alt-fmt fmt x))))
|
|
(cond
|
|
[(pair? x)
|
|
; choose x's format, if any, if it is a read macro or if the
|
|
; incoming format is atomic.
|
|
(let ([fmt (let ([x-fmt (get-pretty-format x)])
|
|
(let ([fmt (select-alt-fmt fmt x)])
|
|
(if (and x-fmt (syntax-case fmt (quote)
|
|
[(quote sym) #t]
|
|
[sym (symbol? #'sym) #t]
|
|
[_ #f]))
|
|
x-fmt
|
|
fmt)))])
|
|
(syntax-case fmt (read-macro meta)
|
|
[(read-macro str sym)
|
|
(cond
|
|
[(and (pair? (cdr x))
|
|
(null? (cddr x))
|
|
(or (not (eq? (car x) '$primitive))
|
|
(symbol? (cadr x))))
|
|
(let ([p (mk-prty (cadr x) lev len 'x)])
|
|
(make-prty fmt (+ (string-length #'str) (prty-len p)) p))]
|
|
[(and (eq? (car x) '$primitive)
|
|
(pair? (cdr x))
|
|
(pair? (cddr x))
|
|
(null? (cdddr x))
|
|
(memv (cadr x) '(2 3))
|
|
(symbol? (caddr x)))
|
|
(let ([p (mk-prty (caddr x) lev len 'x)]
|
|
[s (format "#~d%" (cadr x))])
|
|
(make-prty `(read-macro ,s x)
|
|
(+ (string-length s) (prty-len p))
|
|
p))]
|
|
[else (mk-prty-list x lev len 'x)])]
|
|
[(meta)
|
|
(let ([defn (cdr x)])
|
|
(let ([fmt (and (pair? defn) (get-pretty-format defn))])
|
|
(mk-prty-list x lev len
|
|
(if fmt `(meta . ,fmt) '(meta x #f ...)))))]
|
|
[_ (mk-prty-list x lev len fmt)]))]
|
|
[(vector? x)
|
|
(let ([n (vector-length x)])
|
|
(if (= n 0)
|
|
(if (print-vector-length)
|
|
(make-prty '() 4 "#0()")
|
|
(make-prty '() 3 "#()"))
|
|
(let ([p (mk-prty-vector vector-length vector-ref x lev len)]
|
|
[s (if (print-vector-length) (format "#~d" n) "#")])
|
|
(make-prty `(read-macro ,s x)
|
|
(+ (string-length s) (prty-len p))
|
|
p))))]
|
|
[(fxvector? x)
|
|
(let ([n (fxvector-length x)])
|
|
(if (= n 0)
|
|
(if (print-vector-length)
|
|
(make-prty '() 4 "#0vfx()")
|
|
(make-prty '() 3 "#vfx()"))
|
|
(let ([p (mk-prty-vector fxvector-length fxvector-ref x lev len)]
|
|
[s (if (print-vector-length) (format "#~dvfx" n) "#vfx")])
|
|
(make-prty `(read-macro ,s x)
|
|
(+ (string-length s) (prty-len p))
|
|
p))))]
|
|
[(bytevector? x)
|
|
(let ([n (bytevector-length x)])
|
|
(if (= n 0)
|
|
(if (print-vector-length)
|
|
(make-prty '() 4 "#0vu8()")
|
|
(make-prty '() 3 "#vu8()"))
|
|
(let ([p (mk-prty-vector bytevector-length bytevector-u8-ref x lev len)]
|
|
[s (if (print-vector-length) (format "#~dvu8" n) "#vu8")])
|
|
(make-prty `(read-macro ,s x)
|
|
(+ (string-length s) (prty-len p))
|
|
p))))]
|
|
[(box? x)
|
|
(if (limit? lev)
|
|
(make-prty '() 5 "#&...")
|
|
(let ([r (mk-prty (unbox x) (decr lev) len 'x)])
|
|
(make-prty '(read-macro "#&" x) (+ 2 (prty-len r)) r)))]
|
|
[(eq? x '#0=#0#)
|
|
(if (limit? lev)
|
|
(make-prty 'x 3 "...")
|
|
(mk-prty x (decr lev) len 'x))]
|
|
[else
|
|
($write-pretty-quick x lev len graph-env pretty-string-output-port)
|
|
(let ([s (get-output-string pretty-string-output-port)])
|
|
(make-prty 'x (string-length s) s))])))
|
|
|
|
(define mk-prty-vector
|
|
(lambda (vlen vref x lev len)
|
|
(if (limit? lev)
|
|
(make-prty '() 5 "(...)")
|
|
(let ([prtys
|
|
(let ([m (if (print-vector-length)
|
|
($last-new-vector-element vlen vref x)
|
|
(fx- (vlen x) 1))])
|
|
(if (and len (fx<= len m))
|
|
(mk-prty-vector-help vref
|
|
x (decr lev) len (fx- len 1)
|
|
(list (make-prty '() 3 "...")))
|
|
(mk-prty-vector-help vref
|
|
x (decr lev) len m '())))])
|
|
(make-prty '(fill 0 x ...) (prtys-size prtys) prtys)))))
|
|
|
|
; Order of evaluation is important here to make sure that "#n#" numbers
|
|
; get assigned in order and that the "#n=" assignment comes before any
|
|
; "#n# references.
|
|
|
|
(define mk-prty-vector-help
|
|
(lambda (vref x lev len n prtys-tail)
|
|
(let mk ([i 0])
|
|
(if (fx> i n)
|
|
prtys-tail
|
|
(let ([first (mk-prty (vref x i) lev len 'x)])
|
|
(cons first (mk (fx+ i 1))))))))
|
|
|
|
(define prtys-size
|
|
(lambda (ls)
|
|
(let f ([ls ls] [n 1])
|
|
(if (null? ls)
|
|
n
|
|
(f (cdr ls) (+ (+ (prty-len (car ls)) n) 1))))))
|
|
|
|
(define mk-prty-list
|
|
(lambda (x lev len fmt)
|
|
(let* ([fmt (syntax-case fmt (quote)
|
|
[(quote sym) '()]
|
|
[sym (symbol? #'sym) '()]
|
|
[_ fmt])]
|
|
[prtys (mk-prty-list-help x lev len
|
|
(syntax-case fmt (quote bracket)
|
|
[(bracket . fmt-tail) #'fmt-tail]
|
|
[_ fmt]))])
|
|
(make-prty fmt (prtys-size prtys) prtys))))
|
|
|
|
; Order of evaluation is important here to make sure that "#n#" numbers
|
|
; get assigned in order and that the "#n=" assignment comes before any
|
|
; "#n# references.
|
|
|
|
(define mk-prty-list-help
|
|
(lambda (x lev len fmt-tail)
|
|
(define (fmt-next fmt-tail)
|
|
(syntax-case fmt-tail (fill)
|
|
[() (values 'x '())]
|
|
[(fill tab fmt dots)
|
|
(values #'fmt fmt-tail)]
|
|
[(tab fmt dots)
|
|
(and (tab? #'tab) (dots? #'dots))
|
|
(values #'fmt fmt-tail)]
|
|
[(fmt tab dots)
|
|
(and (tab? #'tab) (dots? #'dots))
|
|
(values #'fmt fmt-tail)]
|
|
[(tab fmt . fmt-tail)
|
|
(tab? #'tab)
|
|
(values #'fmt #'fmt-tail)]
|
|
[(fmt dots)
|
|
(dots? #'dots)
|
|
(values #'fmt fmt-tail)]
|
|
[(fmt . fmt-tail)
|
|
(values #'fmt #'fmt-tail)]))
|
|
(if (or (limit? lev) (limit? len))
|
|
(list (make-prty '() 3 "..."))
|
|
(let-values ([(fmt fmt-tail) (fmt-next fmt-tail)])
|
|
(let ([first (mk-prty (car x) (decr lev) len fmt)])
|
|
(cons first
|
|
(let mk-rest ([x (cdr x)] [n (decr len)] [fmt-tail fmt-tail])
|
|
(cond
|
|
[(null? x) '()]
|
|
[(and (pair? x)
|
|
(not (and graph-env (graph-env 'tag? x)))
|
|
(not (and (eq? (car x) 'unquote)
|
|
(pair? (cdr x))
|
|
(null? (cddr x)))))
|
|
(if (limit? n)
|
|
(list (make-prty '() 3 "..."))
|
|
(let-values ([(fmt fmt-tail) (fmt-next fmt-tail)])
|
|
(let ([next (mk-prty (car x) (decr lev) len fmt)])
|
|
(cons next (mk-rest (cdr x) (decr n) fmt-tail)))))]
|
|
[else
|
|
(list (make-prty '() 1 ".")
|
|
(mk-prty x (decr lev) len 'x))]))))))))
|
|
|
|
(define pretty
|
|
; p = prty object
|
|
; pps = pending parens
|
|
(lambda (p pps)
|
|
(let* ([len (prty-len p)] [oneline (<= (+ len pps) room)])
|
|
(pretty-help p pps oneline))))
|
|
|
|
(define pretty-help
|
|
(lambda (p pps oneline)
|
|
(let ([obj (prty-obj p)] [fmt (prty-fmt p)])
|
|
(cond
|
|
[(string? obj) (pretty-write-prty p)]
|
|
[(not (pair? fmt))
|
|
(pretty-generic (car obj) (cdr obj) pps oneline)]
|
|
[(eq? (car fmt) 'read-macro)
|
|
(pretty-write-string (cadr fmt))
|
|
(pretty obj pps)]
|
|
[else
|
|
(let* ([b? (and (eq? (car fmt) 'bracket) (print-brackets))]
|
|
[fmt (if (eq? (car fmt) 'bracket) (cdr fmt) fmt)])
|
|
(pretty-write-char (if b? lbrack lparen))
|
|
(let ([start col] [pps (+ pps 1)])
|
|
(cond
|
|
[(eq? (car fmt) 'fill)
|
|
(pretty-fill obj start pps oneline (tab-amount (cadr fmt)) #f)]
|
|
[else
|
|
(pretty (car obj) (if (null? (cdr obj)) pps 0))
|
|
(pretty-tail (cdr obj) (cdr fmt) start pps oneline)]))
|
|
(pretty-write-char (if b? rbrack rparen)))]))))
|
|
|
|
(define pretty-fill
|
|
(lambda (obj start pps oneline tab space?)
|
|
; recompute room so that first of multiple lines of fill is treated like
|
|
; the remaining lines, possibly exceeding "one-line-limit" for that line
|
|
(when (> (apply + (map prty-len obj)) (* 2 room))
|
|
(set! room
|
|
(min (- (pretty-line-length) start)
|
|
(pretty-one-line-limit))))
|
|
(let f ([obj obj] [space? space?])
|
|
(let* ([p (car obj)] [len (prty-len p)])
|
|
(cond
|
|
[(or oneline
|
|
(fx<= (fx+ len
|
|
(if (null? (cdr obj)) pps 0)
|
|
(if space? 1 0))
|
|
room))
|
|
(when space? (pretty-write-char #\space))
|
|
(pretty-help p (if (null? (cdr obj)) pps 0) #t)
|
|
(unless (null? (cdr obj)) (f (cdr obj) #t))]
|
|
[space?
|
|
(pretty-tab (+ tab start) #f)
|
|
(f obj #f)]
|
|
[else
|
|
(pretty-help p (if (null? (cdr obj)) pps 0) #f)
|
|
(unless (null? (cdr obj))
|
|
(pretty-tab (+ tab start) #f)
|
|
(f (cdr obj) #f))])))))
|
|
|
|
(define pretty-generic
|
|
(lambda (fcn args pps oneline)
|
|
(pretty-write-char lparen)
|
|
(let ((n (prty-len fcn)) (start col) (pps (+ pps 1)) (nargs (length args)))
|
|
(cond
|
|
((fx= nargs 0) (pretty fcn pps))
|
|
((fx>= nargs 20) ; probably not a procedure call
|
|
(pretty-fill (cons fcn args) start pps oneline 0 #f))
|
|
((<= n (+ si 2))
|
|
(pretty-write-prty fcn)
|
|
(pretty-write-char #\space)
|
|
(if (fx>= nargs 5)
|
|
(pretty-fill args start pps oneline (+ n 1) #f)
|
|
(let f ((l args))
|
|
(if (null? (cdr l))
|
|
(pretty (car l) pps)
|
|
(begin
|
|
(pretty (car l) 0)
|
|
(pretty-tab (1+ (+ start n)) oneline)
|
|
(f (cdr l)))))))
|
|
(else
|
|
(pretty fcn 0)
|
|
(if (fx>= nargs 5)
|
|
(pretty-fill args start pps oneline si #t)
|
|
(let f ((l args))
|
|
(pretty-tab (+ start si) oneline)
|
|
(if (null? (cdr l))
|
|
(pretty (car l) pps)
|
|
(begin
|
|
(pretty (car l) 0)
|
|
(f (cdr l)))))))))
|
|
(pretty-write-char rparen)))
|
|
|
|
(define pretty-tail
|
|
(lambda (obj fmt start pps oneline)
|
|
(cond
|
|
((null? obj)
|
|
; ran out of object, just ignore remaining format
|
|
(void))
|
|
((null? fmt)
|
|
; out of format, try to do something reasonable
|
|
(pretty-tab (+ si start) oneline)
|
|
(pretty (car obj) (if (null? (cdr obj)) pps 0))
|
|
(pretty-tail (cdr obj) '() start pps oneline))
|
|
((tab-amount (car fmt)) =>
|
|
(lambda (tab)
|
|
(cond
|
|
((null? (cdr fmt)) ; shouldn't happen
|
|
; tab at end of format, treat as null format
|
|
(pretty-tail obj '() start pps oneline))
|
|
((dots? (cadr fmt))
|
|
(let f ((l obj))
|
|
(pretty-tab (+ tab start) oneline)
|
|
(if (null? (cdr l))
|
|
(pretty (car l) pps)
|
|
(begin
|
|
(pretty (car l) 0)
|
|
(f (cdr l))))))
|
|
((and (not (null? (cddr fmt))) (dots? (caddr fmt)))
|
|
(let f ((l obj))
|
|
(pretty-tab (+ tab start) oneline)
|
|
(if (null? (cdr l))
|
|
(pretty (car l) pps)
|
|
(begin
|
|
(pretty (car l) 0)
|
|
(f (cdr l))))))
|
|
(else
|
|
(pretty-tab (+ tab start) oneline)
|
|
(pretty (car obj) (if (null? (cdr obj)) pps 0))
|
|
(pretty-tail (cdr obj) (cddr fmt) start pps oneline)))))
|
|
((dots? (car fmt)) ; no newlines...
|
|
(pretty-write-char #\space)
|
|
(pretty (car obj) (if (null? (cdr obj)) pps 0))
|
|
(pretty-tail (cdr obj) fmt start pps oneline))
|
|
((eq? (car fmt) 'fill)
|
|
(pretty-fill obj start pps oneline (tab-amount (cadr fmt)) #t))
|
|
(else
|
|
(pretty-write-char #\space)
|
|
(pretty (car obj) (if (null? (cdr obj)) pps 0))
|
|
(pretty-tail (cdr obj) (cdr fmt) start pps oneline)))))
|
|
|
|
(define pretty-write-char
|
|
(lambda (c)
|
|
(write-char c port)
|
|
(set! col (1+ col))
|
|
(set! room (1- room))))
|
|
|
|
(define pretty-write-string
|
|
(lambda (s)
|
|
(let ((n (string-length s)))
|
|
(display-string s port)
|
|
(set! col (+ col n))
|
|
(set! room (- room n)))))
|
|
|
|
(define pretty-tab
|
|
(lambda (n oneline)
|
|
(if oneline
|
|
(pretty-write-char #\space)
|
|
(begin
|
|
(check-line-maximum)
|
|
(newline port)
|
|
(do ((i n (1- i))) ((zero? i)) (write-char #\space port))
|
|
(set! col n)
|
|
(set! room
|
|
(min (- (pretty-line-length) n)
|
|
(pretty-one-line-limit)))))))
|
|
|
|
(define pretty-write-prty
|
|
(lambda (p)
|
|
(let f ((o (prty-obj p)) (fmt (prty-fmt p)))
|
|
(cond
|
|
((string? o) (display-string o port))
|
|
((and (pair? fmt) (eq? (car fmt) 'read-macro))
|
|
(display-string (cadr fmt) port)
|
|
(f (prty-obj o) (prty-fmt o)))
|
|
(else
|
|
(begin
|
|
(write-char lparen port)
|
|
(f (prty-obj (car o)) (prty-fmt (car o)))
|
|
(for-each
|
|
(lambda (x)
|
|
(write-char #\space port)
|
|
(f (prty-obj x) (prty-fmt x)))
|
|
(cdr o))
|
|
(write-char rparen port)))))
|
|
(set! col (+ col (prty-len p)))
|
|
(set! room (- room (prty-len p)))))
|
|
|
|
(set! pretty-print
|
|
(case-lambda
|
|
[(x) (pretty-print x (current-output-port))]
|
|
[(x p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops 'pretty-print "~s is not a textual output port" p))
|
|
(let ([lev (print-level)]
|
|
[len (print-length)]
|
|
[indent (pretty-initial-indent)])
|
|
(fluid-let ([si (pretty-standard-indent)]
|
|
[lines (pretty-maximum-lines)]
|
|
[col indent]
|
|
[room (min (- (pretty-line-length) indent)
|
|
(pretty-one-line-limit))]
|
|
[port p]
|
|
[pretty-string-output-port (open-output-string)]
|
|
[graph-env ($make-graph-env 'pretty-print x lev len)])
|
|
(check-line-maximum)
|
|
(pretty (mk-prty x lev len 'x) 0)
|
|
(newline port)))]))
|
|
|
|
(set-who! pretty-file
|
|
(lambda (in out)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
(let ([i ($open-file-input-port who in (file-options)
|
|
(buffer-mode block) (current-transcoder))]
|
|
[o ($open-file-output-port who out (file-options replace)
|
|
(buffer-mode block) (current-transcoder))])
|
|
(on-reset
|
|
(begin
|
|
(close-input-port i)
|
|
(delete-file out #f))
|
|
(on-reset
|
|
(close-output-port o)
|
|
(let loop ()
|
|
(let ([x (read i)])
|
|
(unless (eof-object? x)
|
|
(pretty-print x o)
|
|
(newline o)
|
|
(loop))))
|
|
(close-input-port i)
|
|
(close-output-port o))))))
|
|
|
|
(set! pretty-format
|
|
(case-lambda
|
|
[(key)
|
|
(unless (symbol? key)
|
|
($oops 'pretty-format "~s is not a symbol" key))
|
|
($sgetprop key '*pretty-format* #f)]
|
|
[(key fmt)
|
|
(unless (symbol? key)
|
|
($oops 'pretty-format "~s is not a symbol" key))
|
|
(unless (or (eq? fmt #f) (fmt? fmt))
|
|
($oops 'pretty-format "invalid format ~s" fmt))
|
|
(with-tc-mutex
|
|
(if (eq? fmt #f)
|
|
($sremprop key '*pretty-format*)
|
|
($sputprop key '*pretty-format* fmt)))]))
|
|
|
|
(pretty-format 'alias '(_ x y))
|
|
(pretty-format 'and '(_ e 4 ...))
|
|
(pretty-format 'assertion-violation '(_ who #f arg ...))
|
|
(pretty-format 'assertion-violationf '(_ who #f arg ...))
|
|
(pretty-format 'begin '(_ #f e ...))
|
|
(pretty-format 'case '(_ exp #f [bracket (fill 0 k ...) 0 e ...] ...))
|
|
(pretty-format 'case-lambda '(_ #f [bracket (fill 0 x ...) 0 e ...] ...))
|
|
(pretty-format 'cond '(_ #f (alt [bracket test '=> 0 exp] [bracket test 0 exp ...]) ...))
|
|
(pretty-format 'critical-section '(_ #f e ...))
|
|
(pretty-format 'datum '(_ x))
|
|
(pretty-format 'define '(_ (fill 0 x ...) #f e ...))
|
|
(pretty-format 'define-enumeration `(_ x #f ...))
|
|
(pretty-format 'define-property '(_ x #f e ...))
|
|
(pretty-format 'define-record
|
|
'(alt (_ var (x 0 ...))
|
|
(_ var (x 0 ...) #f ([bracket x y] 0 ...))
|
|
(_ var (x 0 ...) #f ([bracket x y] 0 ...) #f ([bracket x y ...] ...))
|
|
(_ var var (x 0 ...))
|
|
(_ var var (x 0 ...) #f ([bracket x y] 0 ...))
|
|
(_ var var (x 0 ...) #f ([bracket x y] 0 ...) #f ([bracket x y ...] ...))))
|
|
; if we had tail alts:
|
|
#;(pretty-format 'define-record
|
|
`(alt (_ var (x 0 ...) . (alt () (#f ([bracket x y] 0 ...) . (alt () (#f ([bracket x y ...] ...))))))
|
|
(_ var var (x 0 ...) . (alt () (#f ([bracket x y] 0 ...) . (alt () (#f ([bracket x y ...] ...))))))))
|
|
(pretty-format 'define-record-type '(_ x #f ...))
|
|
(pretty-format 'define-structure '(_ (x 0 ...) #f ([bracket x 0 ...] 0 ...)))
|
|
(pretty-format 'define-syntax '(_ (x ...) #f e ...))
|
|
(pretty-format 'define-values '(_ (fill 0 x ...) #f e ...))
|
|
(pretty-format 'delay '(_ exp))
|
|
(pretty-format 'exclusive-cond '(_ #f (alt [bracket test '=> 0 exp] [bracket test 0 exp ...]) ...))
|
|
(pretty-format 'do '(_ ([bracket x ...] 0 ...) 3 (e1 0 ...) #f e ...))
|
|
(pretty-format 'endianness '(_ x))
|
|
(pretty-format 'error '(_ who #f arg ...))
|
|
(pretty-format 'errorf '(_ who #f arg ...))
|
|
(pretty-format 'eval-when '(_ (k ...) #f e ...))
|
|
(pretty-format 'extend-syntax '(_ (keys 0 ...) #f [bracket e1 0 e2 ...] ...))
|
|
(pretty-format 'fluid-let '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'fluid-let-syntax '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'foreign-callable
|
|
'(alt (foreign-callable #f proc #f (x 0 ...) #f y)
|
|
(foreign-callable conv #f proc #f (x 0 ...) #f y)))
|
|
(pretty-format 'foreign-procedure
|
|
'(alt (foreign-procedure entry #f (x 0 ...) #f y)
|
|
(foreign-procedure conv entry #f (x 0 ...) #f y)))
|
|
(pretty-format 'guard
|
|
'(_ (_ #f (alt [bracket test '=> 0 exp] [bracket test 0 exp ...]) ...)
|
|
#f e ...))
|
|
(pretty-format 'identifier-syntax
|
|
'(alt (identifier-syntax #f [bracket x x] #f [bracket x x])
|
|
(identifier-syntax x)))
|
|
(pretty-format 'if '(_ exp 3 exp ...))
|
|
(pretty-format 'lambda '(_ (fill 0 x ...) #f e ...))
|
|
(pretty-format 'let
|
|
'(alt (let ([bracket x e] 0 ...) #f e #f e ...)
|
|
(let var ([bracket x e] 0 ...) #f e #f e ...)))
|
|
(pretty-format 'let* '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'letrec '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'letrec* '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'let-values '(_ ([bracket (x ...) 0 e] 0 ...) #f e ...))
|
|
(pretty-format 'let*-values '(_ ([bracket (x ...) 0 e] 0 ...) #f e ...))
|
|
(pretty-format 'let-syntax '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'letrec-syntax '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'library '(_ (name ...) #f e ...))
|
|
(pretty-format 'meta '(meta)) ; meta is handled as a special case
|
|
(pretty-format 'meta-cond '(_ #f (alt [bracket test '=> 0 exp] [bracket test 0 exp ...]) ...))
|
|
(pretty-format 'module
|
|
'(alt (module (fill 0 (alt (fill 0 x ...) x) ...) #f e ...)
|
|
(module var (fill 0 (alt (fill 0 x ...) x) ...) #f e ...)))
|
|
(pretty-format 'or '(_ exp 3 ...))
|
|
(pretty-format 'parameterize '(_ ([bracket x 0 e] 0 ...) #f e ...))
|
|
(pretty-format 'syntax-case '(_ exp (fill 0 lit ...) #f [bracket pat 0 e ...] ...))
|
|
(pretty-format 'syntax-rules '(_ (fill 0 lit ...) #f [bracket pat 0 e ...] ...))
|
|
(pretty-format 'rec '(_ id #f e))
|
|
(pretty-format 'record-case '(_ exp #f [bracket tag (x 0 ...) 0 exp ...] ...))
|
|
(pretty-format 'set! '(_ id #f e ...))
|
|
(pretty-format 'trace-case-lambda '(_ name #f [bracket (fill 0 x ...) 0 e ...] ...))
|
|
(pretty-format 'trace-define '(_ (fill 0 x ...) #f e ...))
|
|
(pretty-format 'trace-define-syntax '(_ (x ...) #f e ...))
|
|
(pretty-format 'trace-do '(_ ([bracket x ...] 0 ...) 3 (e1 0 ...) #f e ...))
|
|
(pretty-format 'trace-lambda '(_ name (fill 0 x ...) #f e ...))
|
|
(pretty-format 'trace-let '(_ name ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'unless '(_ test #f e ...))
|
|
(pretty-format 'warning '(_ who #f arg ...))
|
|
(pretty-format 'warningf '(_ who #f arg ...))
|
|
(pretty-format 'when '(_ test #f e ...))
|
|
(pretty-format 'with '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'with-implicit '(_ (x 0 ...) #f e ...))
|
|
(pretty-format 'with-interrupts-disabled '(_ #f e ...))
|
|
(pretty-format 'with-mutex '(_ x #f e ...))
|
|
(pretty-format 'with-syntax '(_ ([bracket x e] 0 ...) #f e ...))
|
|
|
|
(pretty-format 'quasiquote '(read-macro "`" x))
|
|
(pretty-format 'quasisyntax '(read-macro "#`" x))
|
|
(pretty-format 'quote '(read-macro "'" x))
|
|
(pretty-format 'syntax '(read-macro "#'" x))
|
|
(pretty-format 'unquote '(read-macro "," x))
|
|
(pretty-format 'unquote-splicing '(read-macro ",@" x))
|
|
(pretty-format 'unsyntax '(read-macro "#," x))
|
|
(pretty-format 'unsyntax-splicing '(read-macro "#,@" x))
|
|
(pretty-format '$primitive '(read-macro "#%" x))
|
|
|
|
; ftypes
|
|
(pretty-format 'define-ftype '(_ x #f ...))
|
|
(pretty-format 'struct '(_ #f [bracket x ...] ...))
|
|
(pretty-format 'union '(_ #f [bracket x ...] ...))
|
|
(pretty-format 'array '(_ n #f ...))
|
|
(pretty-format 'bits '(_ #f [bracket x ...] ...))
|
|
(pretty-format 'endian '(_ x #f ...))
|
|
(pretty-format 'packed '(_ #f ...))
|
|
(pretty-format 'unpacked '(_ #f ...))
|
|
|
|
; support for things that aren't built in...
|
|
(pretty-format 'match '(_ x #f [bracket e 0 ...] ...))
|
|
|
|
(record-writer (type-descriptor prty)
|
|
(lambda (x p wr)
|
|
(display "#<prty " p)
|
|
(wr (prty-fmt x) p)
|
|
(write-char #\space p)
|
|
(wr (prty-len x) p)
|
|
(write-char #\space p)
|
|
(wr (prty-obj x) p)
|
|
(write-char #\> p)))
|
|
)
|
|
)
|