added initial pretty-print file to lab

This commit is contained in:
Abdulaziz Ghuloum 2007-01-13 18:34:35 -05:00
parent 53b51e4088
commit 17c1b3ba10
1 changed files with 352 additions and 0 deletions

352
lab/pretty-print.ss Normal file
View File

@ -0,0 +1,352 @@
(module (pretty-print)
(import-only scheme)
(define (pretty-width) 60)
(define-record cbox (length boxes))
(define-record lbox (length boxes))
(define-record sbox (length string))
(define-record pbox (length ls last))
(define (box-length x)
(cond
[(string? x) (string-length x)]
[(cbox? x) (cbox-length x)]
[(lbox? x) (lbox-length x)]
[(sbox? x) (sbox-length x)]
[(pbox? x) (pbox-length x)]
[else (error 'boxify "invalid box ~s" x)]))
(define (boxify x)
(define (conc . a*)
(let ([n
(let f ([a* a*] [len 0])
(cond
[(null? a*) len]
[else
(f (cdr a*) (fx+ len (box-length (car a*))))]))])
(make-cbox n a*)))
(define (boxify-symbol x)
(define (boxify-symbol-string x)
(define (valid-symbol-string? x) #t) ;;; FIXME
(define (barify x) (error 'barify "NOT YET")) ;;; FIXME
(if (valid-symbol-string? x)
x
(conc "|" (barify x) "|")))
(let ([name (symbol->string x)])
(cond
[(gensym? x)
(conc "#:" (boxify-symbol-string name))]
[else (boxify-symbol-string name)])))
(define (boxify-list ls)
(let ([ls (map boxify ls)])
(let ([n
(let f ([ls ls] [n 1])
(cond
[(null? ls) n]
[else
(f (cdr ls)
(fx+ (box-length (car ls)) (fxadd1 n)))]))])
(make-lbox n ls))))
(define (boxify-string x)
(define (count s i j n)
(cond
[(fx= i j) n]
[else
(let ([c (string-ref s i)])
(let ([int (char->integer c)])
(cond
[(assv int string-esc-table) =>
(lambda (t)
(count s (fxadd1 i) j
(fx+ (fx+ n 1) (string-length (cdr t)))))]
[(and (fx<= 32 int) (fx<= int 127))
(count s (fxadd1 i) j (fxadd1 n))]
[else
(count s (fxadd1 i) j (fx+ n 3))])))]))
(let ([n (string-length x)])
(let ([m (count x 0 n 0)])
(if (fx= n m)
(conc "\"" x "\"")
(make-sbox (fx+ m 2) x)))))
(define (boxify-pair x)
(let-values ([(ls last)
(let f ([x x])
(cond
[(pair? x)
(let ([a (boxify (car x))])
(let-values ([(ls last) (f (cdr x))])
(values (cons a ls) last)))]
[else
(values '() (boxify x))]))])
(let ([n
(let f ([ls ls] [n 4])
(cond
[(null? ls) n]
[else
(f (cdr ls)
(fx+ (fxadd1 n) (box-length (car ls))))]))])
(make-pbox (fx+ n (box-length last)) ls last))))
(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 (boxify-char x)
(let ([n (char->integer x)])
(cond
[(fx< n (vector-length char-table))
(conc "#\\" (vector-ref char-table n))]
[(fx< n 128)
(string #\# #\\ x)]
[else
(string #\# #\c
(hexify (fxquotient n 16))
(hexify (fxremainder n 16)))])))
(cond
[(number? x) (number->string x)]
[(symbol? x) (boxify-symbol x)]
[(string? x) (boxify-string x)]
[(null? x) "()"]
[(boolean? x) (if x "#t" "#f")]
;[(vector? x) (boxify-vector x)]
[(list? x) (boxify-list x)]
[(pair? x) (boxify-pair x)]
[(char? x) (boxify-char x)]
[(procedure? x) "#<procedure>"]
[(eq? x (void)) "#<void>"]
[else "#<unknown>"]))
(define string-esc-table
'((7 . "a")
(8 . "b")
(9 . "t")
(10 . "n")
(11 . "v")
(12 . "f")
(13 . "r")
(34 . "\"")
(92 . "\\")))
(define (hexify n)
(cond
[(fx< n 10) (integer->char (fx+ n (char->integer #\0)))]
[else (integer->char (fx+ (fx- n 10) (char->integer #\A)))]))
(define (output x p)
(define (output-sbox x p col)
(display #\" p)
(let ([str (sbox-string x)])
(let f ([i 0] [n (string-length str)] [str str] [p p] [col col])
(cond
[(fx= i n)
(display #\" p)
(fx+ col 2)]
[else
(let ([c (string-ref str i)])
(let ([int (char->integer c)])
(cond
[(assv int string-esc-table) =>
(lambda (t)
(display #\\ p)
(display (cdr t) p)
(f (fxadd1 i) n str p
(fx+ col (fxadd1 (string-length (cdr t))))))]
[(and (fx<= 32 int) (fx<= int 127))
(display c p)
(f (fxadd1 i) n str p (fxadd1 col))]
[else
(display #\\ p)
(display (hexify (fxquotient int 16)) p)
(display (hexify (fxremainder int 16)) p)
(f (fxadd1 i) n str p
(fx+ col 3))])))]))))
(define (output-cbox x p col)
(let g ([ls (cbox-boxes x)] [p p] [col col])
(cond
[(null? ls) col]
[else
(g (cdr ls) p
(f (car ls) p col))])))
(define (tab col p)
(newline p)
(let f ([col col] [p p])
(unless (fxzero? col)
(display #\space p)
(f (fxsub1 col) p))))
(define (output-lbox x p col)
(define (lbox-one-line x p col ls)
(display "(" p)
(let g ([ls (cdr ls)] [p p]
[col (f (car ls) p (fx+ col 1))])
(cond
[(null? ls)
(display ")" p)
(fx+ col 1)]
[else
(display " " p)
(g (cdr ls) p
(f (car ls) p (fxadd1 col)))])))
(define (lbox-multi-line x p col ls)
(display "(" p)
(let ([col (fx+ col 1)])
(f (car ls) p col)
(let g ([ls (cdr ls)] [p p] [col col])
(cond
[(null? ls) (display ")" p) col]
[else
(tab col p)
(f (car ls) p col)
(g (cdr ls) p col)]))))
(define (lbox-multi-fill x p col ls)
(display "(" p)
(let g ([ls (cdr ls)] [p p]
[start-col (fx+ col 2)]
[where #f]
[col (f (car ls) p (fx+ col 1))])
(cond
[(null? ls) (display ")" p) (fx+ col 1)]
[where
(case where
[(end)
(tab start-col p)
(g ls p start-col 'start start-col)]
[(start)
(g (cdr ls) p start-col
(if (fx>= (fx+ start-col (box-length (car ls)))
(pretty-width))
'end #f)
(f (car ls) p start-col))])]
[(fx<= (fx+ (fx+ col 1) (box-length (car ls)))
(pretty-width))
; fits in the rest of the current line
(display " " p)
(g (cdr ls) p start-col
#f
(f (car ls) p (fx+ col 1)))]
[else
(g ls p start-col 'end col)]
#;[else
; too big, give it a new line
(tab start-col p)
(f (car ls) p start-col)
(g (cdr ls) p start-col 'end start-col)])))
(let ([ls (lbox-boxes x)])
(cond
[(null? ls) (display "()" p) (fx+ col 2)]
[(fx<= (fx+ (fx+ col 2) (lbox-length x))
(pretty-width))
(lbox-one-line x p col ls)]
[else
(lbox-multi-fill x p col ls)])))
(define (output-pbox x p col)
(define (pbox-one-line x p col)
(display "(" p)
(let g ([ls (pbox-ls x)]
[p p]
[col (fx+ col 1)]
[last (pbox-last x)])
(cond
[(null? ls)
(display ". " p)
(let ([col (f last p (fx+ col 2))])
(display ")" p)
(fx+ col 1))]
[else
(let ([col (f (car ls) p col)])
(display " " p)
(g (cdr ls) p (fx+ col 1) last))])))
(define (pbox-multi-fill x p col)
(display "(" p)
(let g ([ls (cdr (pbox-ls x))]
[p p]
[start-col (fx+ col 1)]
[col (f (car (pbox-ls x)) p (fx+ col 1))]
[last (pbox-last x)])
(cond
[(null? ls)
(let ([n (box-length last)])
(let ([col
(cond
[(fx<= (fx+ (fx+ col n) 4) (pretty-width))
(display " . " p)
(fx+ col 3)]
[else
(tab start-col p)
(display ". " p)
(fx+ start-col 2)])])
(let ([col (f last p col)])
(display ")" p)
(fx+ col 1))))]
[(fx<= (fx+ (fx+ col 1) (box-length (car ls)))
(pretty-width))
(display " " p)
(g (cdr ls) p start-col
(f (car ls) p (fx+ col 1))
last)]
[else
(tab start-col p)
(g (cdr ls) p start-col
(f (car ls) p start-col)
last)])))
(cond
[(fx<= (fx+ col (pbox-length x)) (pretty-width))
(pbox-one-line x p col)]
[else
(pbox-multi-fill x p col)]))
(define (f x p col)
(cond
[(string? x)
(display x p)
(fx+ col (string-length x))]
[(cbox? x) (output-cbox x p col)]
[(lbox? x) (output-lbox x p col)]
[(sbox? x) (output-sbox x p col)]
[(pbox? x) (output-pbox x p col)]
[else (error 'pretty-print-output "invalid ~s" x)]))
(f x p 0)
(newline p))
;;;
(define (pretty x p)
(let ([x (boxify x)])
(output x p)))
;;;
(define pretty-print
(case-lambda
[(x) (pretty x (current-output-port))]
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "~s is not an output port" p))])))
(define (test x)
(pretty-print x)
(printf "====================================\n"))
(test 12)
(test #t)
(test #f)
(test (if #f #f))
(test '())
(test "string")
(test "\n")
(test "\r")
(test (string (integer->char 0)))
(test (string (integer->char 240)))
(test 'hello)
(test '(foo bar))
(test '
(define pp
(case-lambda
[(x) (pretty x (current-output-port))]
[(x p)
(if (output-port? p)
(pretty x p)
(error 'pretty-print "~s is not an output port" p))])))
(with-input-from-file "pretty-print.ss"
(lambda ()
(let f ()
(let ([x (read)])
(unless (eof-object? x)
(test x)
(f))))))
(test '(384 7384 83947 893478 9137489 3894789 134789314 79817238
97314897 318947138974 981374 89137489 1374897 13498713
894713894 137894 89137489 1374 891348314 12 17 9000000 . 17))