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

44
collects/mzlib/pretty.ss
View File

@ -29,6 +29,7 @@
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
@ -179,6 +180,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?)
(letrec ([pretty-print (letrec ([pretty-print
@ -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
@ -1016,6 +1036,18 @@
(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))))
(let ((head (car l)) (tail (cdr l))) (let ((head (car l)) (tail (cdr l)))