guile-charting/charting/csv.scm

;; guile-charting
;; Copyright (C) 2008, 2012, 2014, 2015, 2019 Andy Wingo <wingo at pobox dot com>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, see
;; <http://www.gnu.org/licenses/>.

(define-module (charting csv)
  #:use-module (ice-9 optargs)
  #:export (write-csv-row
            write-csv-rows
            csv-read
            csv-port->row-list))

(define (write-csv-row port row delimiter)
  (define special-chars (char-set delimiter #\" #\newline))
  (define (escape-quotes elt)
    (string-join (string-split elt #\") "\"\""))
  (define (escape-element elt)
    (let ((elt (if (string? elt) elt (object->string elt))))
      (if (string-any special-chars elt)
          (string-append "\"" (escape-quotes elt) "\"")
          elt)))
  (display (string-join (map escape-element (vector->list row))
                        (string delimiter))
           port)
  (newline port))

(define (write-csv-rows port rows delimiter)
  (for-each (lambda (row) (write-csv-row port row delimiter)) rows))

;;; FIXME: rewrite with some kind of parser generator? functional, of
;;; course :-) Based on code from Ken Anderson <kanderson bbn com>, from
;;; http://article.gmane.org/gmane.lisp.guile.user/2269.

(define (csv-read-row port delimiter have-cell init-seed)
  (define (!)
    (let ((c (read-char port)))
      c))
  (define (finish-cell b seed)
    (have-cell (list->string (reverse b)) seed))
  (define (next-cell b seed)
    (state-init (!) (finish-cell b seed)))
  (define (state-init c seed)
    (cond ((eqv? c delimiter) (state-init (!) (have-cell "" seed)))
          ((eqv? c #\") (state-string (!) '() seed))
          ((eqv? c #\newline) seed)
          ((eof-object? c) seed)
          (else (state-any c '() seed))))
  (define (state-string c b seed)
    (cond ((eqv? c #\") (state-string-quote (!) b seed))
          ((eof-object? c) (error "Open double-quoted string" (list->string (reverse b))))
          (else (state-string (!) (cons c b) seed))))
  (define (state-string-quote c b seed)
    (cond ((eqv? c #\") (state-string (!) (cons c b) seed)) ; Escaped double quote.
          ((eqv? c delimiter) (next-cell b seed))
          ((eqv? c #\newline) (finish-cell b seed))
          ((eof-object? c)    (finish-cell b seed))
          (else (error "Single double quote at unexpected place." c b))))
  (define (state-any c b seed)
    (cond ((eqv? c delimiter) (next-cell b seed))
          ((eqv? c #\newline) (finish-cell b seed))
          ((eof-object? c)    (finish-cell b seed))
          (else (state-any (!) (cons c b) seed))))
  (state-init (!) init-seed))
  
(define (csv-read port delimiter new-row have-cell have-row init-seed)
  (let lp ((seed init-seed))
    (cond
     ((eof-object? (peek-char port)) seed)
     (else (lp (have-row (csv-read-row port delimiter have-cell (new-row seed))
                         seed))))))

(define* (csv-port->row-list #:optional (port (current-input-port)) (delimiter #\,))
  (reverse
   (csv-read port
             delimiter
             (lambda (rows) '())
             (lambda (cell row) (cons cell row))
             (lambda (row rows) (cons (list->vector (reverse row)) rows))
             '())))