; form letters
(define (read-file file-name)
(with-input-from-file file-name (lambda ()
(let loop ((c (read-char)) (cs '()))
(if (eof-object? c) (reverse cs)
(loop (read-char) (cons c cs)))))))
(define (read-csv-record . args)
(define (read-csv delim port)
(define (add-field field fields)
(cons (list->string (reverse field)) fields))
(define (start field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (reverse fields))
((char=? #\return c) (carriage-return field fields))
((char=? #\newline c) (line-feed field fields))
((char=? #\" c) (quoted-field field fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (not-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (cons "" fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? #\" c) (quoted-field field fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (quoted-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\" c) (may-be-doubled-quotes field fields))
(else (quoted-field (cons c field) fields)))))
(define (may-be-doubled-quotes field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? #\" c) (quoted-field (cons #\" field) fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (unquoted-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (carriage-return field fields)
(let ((c (peek-char port)))
(cond ((eof-object? c) fields)
((char=? #\newline c) (read-char port) fields)
(else fields))))
(define (line-feed field fields)
(let ((c (peek-char port)))
(cond ((eof-object? c) fields)
((char=? #\return c) (read-char port) fields)
(else fields))))
(if (eof-object? (peek-char port)) (peek-char port) (reverse (start '() '()))))
(cond ((null? args) (read-csv #\, (current-input-port)))
((and (null? (cdr args)) (char? (car args)))
(read-csv (car args) (current-input-port)))
((and (null? (cdr args)) (port? (car args)))
(read-csv #\, (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(read-csv (car args) (cadr args)))
(else (read-csv #\, (current-input-port)))))
(define (for-each-port reader proc . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((item (reader p)))
(if (not (eof-object? item))
(begin (proc item) (loop (reader p)))))))
(define (print-form-letter schema rec)
(let loop1 ((schema schema))
(cond ((null? schema) (newline))
((char=? (car schema) #\$)
(let loop2 ((schema (cdr schema)) (n 0))
(cond ((and (pair? schema) (char=? (car schema) #\$))
(display #\$) (loop1 (cdr schema)))
((or (null? schema)
(not (char-numeric? (car schema))))
(display (list-ref rec n))
(loop1 schema))
(else (loop2 (cdr schema)
(+ (* n 10)
(- (char->integer (car schema))
(char->integer #\0))))))))
(else (display (car schema))
(loop1 (cdr schema))))))
(define (form-letters schema-file data-file)
(let* ((schema (read-file schema-file))
(proc (lambda (rec) (print-form-letter schema rec))))
(with-input-from-file data-file
(lambda () (for-each-port read-csv-record proc)))))