customizing write-char (was Re: Format strings are wrong) Alex Shinn 30 Dec 2003 04:07 UTC
Taylor's idea of passing a custom write-char is not so useful by itself, but if you turn it into a FOLD operation then you can get more interesting results. Below is an implementation of fundamental write/display enumerators and some examples of customizing them. Although interesting, I don't think this could taken seriously due to being extremely slow. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; general string utilities (define (display->string x) (with-output-to-string (lambda () (display x)))) (define (write->string x) (with-output-to-string (lambda () (write x)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; kind of a fold for folders, or a partial application compose ;; (procN kons ... (proc2 kons (proc1 kons knil))) (define (cat>> kons knil procs) (let loop ((ls procs) (acc knil)) (if (null? ls) acc (loop (cdr ls) ((car ls) kons acc))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; basic formatters (define (display>> obj) (lambda (kons knil) (cond ((string? obj) (string-fold kons knil obj)) ((pair? obj) (kons #\) (let loop ((acc (kons #\( knil)) (ls obj)) (let ((acc2 ((display>> (car ls)) kons acc)) (rest (cdr ls))) (cond ((null? rest) acc2) ((pair? rest) (loop (kons #\space acc2) rest)) (else ((display>> rest) kons ((display>> kons) acc2 " . ")))))))) ((vector? obj) ((display>> (vector->list obj)) kons (kons #\# knil))) (else ;; add more cases to avoid this ((display>> (display->string obj)) kons knil))))) (define (write>> obj) (lambda (kons knil) (cond ((string? obj) (kons #\" (string-fold kons (kons #\" knil) obj))) ((pair? obj) (kons #\) (let loop ((acc (kons #\( knil)) (ls obj)) (let ((acc2 ((write>> (car ls)) kons acc)) (rest (cdr ls))) (cond ((null? rest) acc2) ((pair? rest) (loop (kons #\space acc2) rest)) (else ((write>> rest) kons ((write>> " . ") kons acc2)))))))) ((vector? obj) ((write>> (vector->list obj)) kons (kons #\# knil))) (else ;; note, intentionally display>> ((display>> (write->string obj)) kons knil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; example 1: formatting with a column counter (define (column-writer c i) (write-char c) (if (eqv? c #\newline) 0 (+ i 1))) (define (fmt>> . procs) (cat>> column-writer 0 procs)) ;; a "constant" procedure (define (fresh-line kons knil) (if (zero? knil) knil (kons #\newline knil))) (define (tab>> col . opt) (lambda (kons knil) (let* ((modulo? (and (pair? opt) (car opt))) (width (if modulo? (modulo col knil) (- col knil)))) (if (positive? width) ((display>> (make-string width #\space)) kons knil) knil)))) ; (fmt>> (display>> "value: ") (write>> '(a "b" 3)) fresh-line) ; (fmt>> (display>> "Name: ") (write>> "Socrates") (tab>> 20) ; (display>> "Sex: ") (write>> "male") fresh-line ; (display>> "Location: ") (write>> "Athens") (tab>> 20) ; (display>> "Job: ") (write>> "corrupting the youth") fresh-line) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; example 2: case folding (define (upcase>> . procs) (lambda (kons knil) (cat>> (lambda (c i) (kons (char-upcase c) i)) knil procs))) (define (downcase>> . procs) (lambda (kons knil) (cat>> (lambda (c i) (kons (char-downcase c) i)) knil procs))) ;; titlecase requires storing previous char's script type in the ;; accumulator ; (fmt>> (upcase>> (display>> "hElLo ")) (downcase>> (display>> "WOrlD!"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; example 3: default radix ;; This example changes the meaning of the accumulator from ;; current-column to current-radix. Similarly you could specify default ;; precision for floating point numbers. A full-featured set of ;; formatting procedures would probably define a record to hold various ;; state information and pass that as the accumulator. ;; current radix is stored in knil (define (number>> n . opt) (lambda (kons knil) (let ((radix (if (pair? opt) (car opt) knil))) ((display>> (number->string n radix)) kons knil)))) ;; just overrides current radix (define (radix>> radix . procs) (lambda (kons knil) (cat>> kons radix procs))) ;; start off with default radix 10 (define (fmt-radix>> . procs) (cat>> (lambda (c i) (write-char c) i) 10 procs)) ; (fmt-radix>> (display>> "decimal: ") (number>> 123) ; (radix>> 16 ; (display>> " hex: ") (number>> 123) ; (display>> " octal: ") (number>> 123 8))) -- Alex