suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added pretty-print-remap-stylable

Browse Source 
svn: r5808
This commit is contained in:
Robby Findler 2007-03-21 20:09:11 +00:00
parent 6920a13ddf
commit a0f85de2e4
1 changed files with 40 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/mzlib/pretty.ss
View File

@ -29,7 +29,8 @@
pretty-print-style-table? pretty-print-style-table?
pretty-print-current-style-table pretty-print-current-style-table
pretty-print-extend-style-table pretty-print-extend-style-table
pretty-print-remap-stylable
pretty-printing pretty-printing
pretty-print-newline pretty-print-newline
make-tentative-pretty-print-output-port make-tentative-pretty-print-output-port
@ -178,6 +179,23 @@
(define pretty-printing (define pretty-printing
(make-parameter #f (lambda (x) (and x #t)))) (make-parameter #f (lambda (x) (and x #t))))
(define pretty-print-remap-stylable
(make-parameter (λ (x) #f)
(λ (f)
(unless (can-accept-n? 1 f)
(raise-type-error
'pretty-print-remap-stylable
"procedure of 1 argument"
f))
(λ (x)
(let ([res (f x)])
(unless (or (not res) (symbol? res))
(raise-type-error
'pretty-print-remap-stylable
"result of parameter function to be a symbol or #f"
res))
res)))))
(define make-pretty-print (define make-pretty-print
(lambda (display?) (lambda (display?)
@ -801,12 +819,17 @@
pp-expr pp-expr
depth)) depth))
(let ((head (car expr))) (let ((head (car expr)))
(if (and (symbol? head) (if (or (and (symbol? head)
(not (size-hook head display?))) (not (size-hook head display?)))
((pretty-print-remap-stylable) head))
(let ((proc (style head))) (let ((proc (style head)))
(if proc (if proc
(proc expr extra depth) (proc expr extra depth)
(if (> (string-length (symbol->string head)) (if (> (string-length
(symbol->string
(if (symbol? head)
head
((pretty-print-remap-stylable) head))))
max-call-head-width) max-call-head-width)
(pp-general expr extra #f #f #f pp-expr depth) (pp-general expr extra #f #f #f pp-expr depth)
(pp-list expr extra pp-expr #t depth)))) (pp-list expr extra pp-expr #t depth))))
@ -965,10 +988,7 @@
(define max-call-head-width 5) (define max-call-head-width 5)
(define (style head) (define (style head)
(case (or (hash-table-get (pretty-print-style-table-hash (case (or (look-in-style-table head)
(pretty-print-current-style-table))
head
(lambda () #f))
head) head)
((lambda λ define define-macro define-syntax ((lambda λ define define-macro define-syntax
syntax-rules syntax-rules
@ -1015,6 +1035,18 @@
(wr* pport obj depth display?))) (wr* pport obj depth display?)))
(let-values ([(l col p) (port-next-location pport)]) (let-values ([(l col p) (port-next-location pport)])
((printing-port-print-line pport) #f col width))) ((printing-port-print-line pport) #f col width)))
(define (look-in-style-table raw-head)
(let ([head
(cond
[((pretty-print-remap-stylable) raw-head)
=>
values]
[else raw-head])])
(hash-table-get (pretty-print-style-table-hash
(pretty-print-current-style-table))
head
#f)))
(define (read-macro? l) (define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l)))) (define (length1? l) (and (pair? l) (null? (cdr l))))