[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/ug3oKyMJ    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Jan 13:
(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

; READ-CSV-RECORD [DELIM] [PORT]
(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)))))

; FOR-EACH-PORT READER PROC [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 (write-html-record rec)
  (display "<tr>")
  (for-each
    (lambda (field)
      (display "<td>")
      (display field)
      (display "</td>"))
    rec)
  (display "</tr>")
  (newline))

(define (csv->html)
  (display "<table>")
  (newline)
  (for-each-port
    read-csv-record
    write-html-record)
  (display "</table>")
  (newline))

(define emp-data-csv
  (string-join #\newline
    '("Beth,12.75,0,mfg"
      "Dan,8.50,10,sales"
      "Kathy,11.40,30,sales"
      "Mark,12.75,40,mfg"
      "Mary,7.50,20,mfg"
      "Susie,10.30,25,acctg")))

(define emp-data-html
  (with-input-from-string
    emp-data-csv
    (lambda ()
      (with-output-to-string
        (lambda ()
          (csv->html))))))

(display emp-data-html)


Create a new paste based on this one


Comments: