codepad

Language:

; 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)))))

Private [?]

Run code