114 lines
4.4 KiB
Scheme
114 lines
4.4 KiB
Scheme
|
|
;; FIXME: Need to disable printing of structs with custom-write property
|
|
|
|
(module pretty-printer mzscheme
|
|
(require (lib "list.ss")
|
|
(lib "class.ss")
|
|
(lib "pretty.ss")
|
|
(lib "mred.ss" "mred")
|
|
"pretty-range.ss"
|
|
"pretty-helper.ss"
|
|
"interfaces.ss"
|
|
"params.ss")
|
|
(provide syntax-pp%
|
|
(struct range (obj start end)))
|
|
|
|
;; syntax-pp%
|
|
;; Pretty printer for syntax objects.
|
|
(define syntax-pp%
|
|
(class* object% (syntax-pp<%>)
|
|
(init-field main-stx)
|
|
(init-field typesetter)
|
|
(init-field (primary-partition #f))
|
|
(init-field (columns (current-default-columns)))
|
|
|
|
(unless (syntax? main-stx)
|
|
(error 'syntax-pretty-printer "got non-syntax object: ~s" main-stx))
|
|
|
|
(define datum #f)
|
|
(define ht:flat=>stx #f)
|
|
(define ht:stx=>flat #f)
|
|
(define identifier-list null)
|
|
(define -range #f)
|
|
|
|
(define/public (get-range) -range)
|
|
(define/public (get-identifier-list) identifier-list)
|
|
(define/public (flat=>stx obj)
|
|
(hash-table-get ht:flat=>stx obj))
|
|
(define/public (stx=>flat obj)
|
|
(hash-table-get ht:stx=>flat obj))
|
|
|
|
(define/public (pretty-print-syntax)
|
|
(define range (new ranges%))
|
|
(define (pp-pre-hook obj port)
|
|
(send range set-start obj (send typesetter get-current-position)))
|
|
(define (pp-post-hook obj port)
|
|
(let ([start (send range get-start obj)]
|
|
[end (send typesetter get-current-position)])
|
|
(when start
|
|
(send range add-range
|
|
(flat=>stx obj)
|
|
(cons start end)))))
|
|
(define (pp-size-hook obj display-like? port)
|
|
(cond [(is-a? obj editor-snip%)
|
|
columns]
|
|
[(syntax-dummy? obj)
|
|
(let ((ostring (open-output-string)))
|
|
((if display-like? display write) (syntax-dummy-val obj) ostring)
|
|
(string-length (get-output-string ostring)))]
|
|
[else #f]))
|
|
(define (pp-print-hook obj display-like? port)
|
|
(cond [(syntax-dummy? obj)
|
|
((if display-like? display write) (syntax-dummy-val obj) port)]
|
|
[(is-a? obj editor-snip%)
|
|
(write-special obj port)]
|
|
[else
|
|
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
|
(define (pp-extend-style-table)
|
|
(let* ([ids identifier-list]
|
|
[syms (map (lambda (x) (stx=>flat x)) ids)]
|
|
[like-syms (map syntax-e ids)])
|
|
(pretty-print-extend-style-table (pp-better-style-table)
|
|
syms
|
|
like-syms)))
|
|
(define (pp-better-style-table)
|
|
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
|
(map car extended-style-list)
|
|
(map cdr extended-style-list)))
|
|
|
|
(parameterize
|
|
([pretty-print-pre-print-hook pp-pre-hook]
|
|
[pretty-print-post-print-hook pp-post-hook]
|
|
[pretty-print-size-hook pp-size-hook]
|
|
[pretty-print-print-hook pp-print-hook]
|
|
[pretty-print-columns columns]
|
|
[pretty-print-current-style-table (pp-extend-style-table)]
|
|
;; Printing parameters (mzscheme manual 7.9.1.4)
|
|
[print-unreadable #t]
|
|
[print-graph #f]
|
|
[print-struct #f]
|
|
[print-box #t]
|
|
[print-vector-length #t]
|
|
[print-hash-table #f]
|
|
[print-honu #f])
|
|
(pretty-print datum (send typesetter get-output-port))
|
|
(set! -range range)))
|
|
|
|
;; recompute-tables : -> void
|
|
(define/private (recompute-tables)
|
|
(set!-values (datum ht:flat=>stx ht:stx=>flat)
|
|
(syntax->datum/tables main-stx primary-partition
|
|
(length (current-colors))
|
|
(current-suffix-option)))
|
|
(set! identifier-list
|
|
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))))
|
|
|
|
;; Initialization
|
|
(recompute-tables)
|
|
(super-new)))
|
|
|
|
(define extended-style-list
|
|
'((define-values . define)
|
|
(define-syntaxes . define-syntax)))
|
|
)
|