LAMBDA: The Ultimate Formatter (was Re: Format strings are wrong)

[Taylor Campbell <campbell@xxxxxxxxxxxx>]

;; Requires some non-R5RS utilities:
;;   - (CALL-WITH-OUTPUT-STRING <consumer>) -> string
;;         (CONSUMER <output-port>)
;;   - (ERROR <message> <irritant> ...)
;;       Used in one place to signal a 'too many arguments' error.
;;   - (ASCII-LIMIT) -> exact, nonnegative integer
;;       The maximum number of ASCII characters.
;;   - (CHAR->ASCII <char>) -> exact, nonnegative integer
;;       The ASCII numeric value for CHAR.
;;       (CHAR->INTEGER doesn't mandate ASCII.)

(define (format formatter write-char)
  (formatter write-char))

(define (format/string formatter)
  (call-with-output-string
    (lambda (out)
      (format formatter (lambda (c) (write-char c out))))))
(define (format/port formatter . maybe-out)
  (format formatter
    (cond ((null? maybe-out)
           write-char)
          ((null? (cdr maybe-out))
           (let ((out (car maybe-out)))
             (lambda (c) (write-char c out))))
          (else
           (error "Too many arguments"
                  (cons format/port (cons formatter maybe-out)))))))
(define (format/char-list formatter)
  (let ((l '()))
    (format formatter (lambda (c) (set! l (cons c l))))
    (reverse l)))

(define (sequence-formatter . formatters)
  (lambda (write-char)
    (for-each (lambda (f) (format f write-char)) formatters)))

(define (string-formatter string)
  (let ((len (string-length string)))
    (lambda (write-char)
      (do ((i 0 (+ i 1))) ((= i len))
        (write-char (string-ref string i))))))
(define (string-literal-formatter string)
  (let ((f (string-formatter string)))
    (lambda (write-char)
      (write-char #\")
      (format f write-char)
      (write-char #\"))))

(define (symbol-formatter symbol)
  (string-formatter (symbol->string symbol)))

;; This is just a simple example using NUMBER->STRING; there should, of 
course,
;; be real numeric formatting routines with a lot more power than just 
over the
;; radix.
(define (number-formatter number radix)
  (string-formatter (number->string number radix)))

(define (boolean-formatter boolean)
  (string-formatter (if boolean "#t" "#f")))

(define (char-formatter char)
  (lambda (write-char)
    (write-char char)))
(define (char-literal-formatter char)
  (let ((f (cond ((char-name char)
                  => (lambda (x)
                       ((if (string? x) string-formatter 
symbol-formatter)
                        x)))
                 (else
                  (char-formatter char)))))
    (lambda (write-char)
      (write-char #\#)
      (write-char #\\)
      (format f write-char))))
;; Make the named characters print more nicely.
(define *char-names* (make-vector (ascii-limit) #f))
(define (char-name char)
  (vector-ref  *char-names* (char->ascii char)))
(define (define-char-name char name)
  (vector-set! *char-names* (char->ascii char) name))
(define-char-name #\space 'space)
(define-char-name #\newline 'newline)
;; Does R5RS define any other named characters?

;; Handles proper & dotted lists, but not circular lists.
(define (list-formatter l x->formatter)
  (cond ((null? l)
         ;; Empty proper list case
         (string-formatter "()"))
        ((not (pair? l))
         ;; Empty dotted list case
         (x->formatter l))
        (else
         ;; Nonempty either list kind case
         (apply sequence-formatter (build-formatter-list l 
x->formatter)))))

(define (build-formatter-list l x->formatter)
  (cons (char-formatter #\()
        (cons (x->formatter (car l))
              (let recur ((l (cdr l)))
                (cond ((null? l)
                       (list (char-formatter #\))))
                      ((not (pair? l))
                       (list (string-formatter " . ")
                             (x->formatter l)
                             (char-formatter #\))))
                      (else
                       (cons (char-formatter #\space)
                             (cons (x->formatter (car l))
                                   (recur (cdr l))))))))))

(define (vector-formatter vec x->formatter)
  ;; This is a cheat.  A real implementation would use a 
straightforward vector
  ;; element formatter.
  (sequence-formatter (char-formatter #\#)
                      (list-formatter (vector->list vec) x->formatter)))

;; These two could be a bit more efficient if the formatting library 
were to be
;; integrated with the implementations of DISPLAY & WRITE, by not 
allocating an
;; intermediate string and generating the formatter for that.
(define (write-formatter object)
  (string-formatter (call-with-output-string
                      (lambda (out) (write object out)))))

(define (display-formatter object)
  (string-formatter (call-with-output-string
                      (lambda (out) (display object out)))))