turn format strings into a procedure

srfi-28-compiler.scm

#!r6rs
;; a toy for turning srfi 28 format strings into a procedure, that
;; performs the format, and outputs to stdout
(library (toys srfi-28-compiler)
(export format-string->procedure)
(import (rnrs)
        (only (srfi :1 lists) fold)
        (srfi :8 receive))

(define (escape-char? char)
  (char=? char #\~))

(define (read-normal chars groups count)
  (cond ((null? chars)
         (values (reverse groups) count))
        ((escape-char? (car chars))
         (read-escape-sequence (cdr chars) groups count))
        (else
         (read-string chars groups count))))

(define (read-string chars groups count)
  (let loop ((str-chars '()) (chars chars))
    (if (or (null? chars)
            (escape-char? (car chars)))
        (read-normal chars
                     (cons (let ((str (list->string (reverse str-chars))))
                             (lambda (args port)
                               (display str port)))
                           groups)
                     count)
        (loop (cons (car chars) str-chars)
              (cdr chars)))))

(define (read-escape-sequence chars groups count)
  (if (null? chars)
      (error 'format-string->procedure "Incomplete escape sequence")
      (case (car chars)
        ((#\~)
         (read-normal (cdr chars)
                      (cons (lambda (args port)
                              (display #\~))
                            groups)
                      count))
        ((#\%)
         (read-normal (cdr chars)
                      (cons (lambda (args port)
                              (newline port))
                            groups)
                      count))
        ((#\a)
         (read-normal (cdr chars)
                      (cons (lambda (args port)
                              (display (list-ref args count) port))
                            groups)
                      (+ count 1)))
        ((#\s)
         (read-normal (cdr chars)
                      (cons (lambda (args port)
                              (write (list-ref args count) port))
                            groups)
                      (+ count 1)))
        (else
         (error 'format-string->procedure
                "Unrecognised escape sequence"
                (car chars))))))

(define (format-string->procedure format-string)
  (receive (groups final-count)
      (read-normal (string->list format-string) '() 0)
    (lambda args
      (let ((len (length args))
            ;; for now, just stdout
            (port (current-output-port)))
        (if (= len final-count)
            (for-each (lambda (proc)
                        (proc args port))
                      groups)
            (error #f
                   "format procedure called with wrong number of arguments:"
                   (list 'expected final-count)
                   (list 'got len)))))))

)

;; (define hello (format-string->procedure "Hello, ~a.~%"))
;; (hello "World")
;; |- "Hello, World.\n"