[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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

This page is part of the web mail archives of SRFI 48 from before July 7th, 2015. The new archives for SRFI 48 contain all messages, not just those from before July 7th, 2015.

;; 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)
    (lambda (out)
      (format formatter (lambda (c) (write-char c out))))))
(define (format/port formatter . maybe-out)
  (format formatter
    (cond ((null? maybe-out)
          ((null? (cdr maybe-out))
           (let ((out (car maybe-out)))
             (lambda (c) (write-char c out))))
           (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)
                  (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))
         ;; 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 #\))))
                       (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)))))