(import magic-pipes)
(import args)
(import (chicken io))
(import (chicken process-context))
(import alist-lib)
(import srfi-1)
(import srfi-13)
(import srfi-14)

;; field-quote or char-quote may be #f
(define ((make-csv-writer record-sep field-sep field-quote char-quote)
         record)
  (let* ((metachars
          (list->char-set
           (filter (lambda (x) x)
            (list record-sep field-sep field-quote char-quote))))
         (write-field
          (lambda (field)
            (if (not (string-index field metachars))
                (write-string field)
                ;; We need to quote some funny characters in the field
                (if field-quote
                    (begin ;; Use field quotes
                      (write-char field-quote)
                      (if char-quote
                          ;; Use char quotes inside field quotes
                          (string-for-each
                          (lambda (ch)
                            (if (or (eq? char-quote ch)
                                    (eq? field-quote ch))
                                (begin
                                  (write-char char-quote)
                                  (write-char ch))
                                (write-char ch)))
                          field)
                         ;; Use doubled field quotes
                         (string-for-each
                          (lambda (ch)
                            (if (eq? field-quote ch)
                                (begin
                                  (write-char field-quote)
                                  (write-char ch))
                                (write-char ch)))
                          field))
                     (write-char field-quote))
                   ;; Use char quotes
                   (string-for-each
                    (lambda (ch)
                      (if (char-set-contains? metachars ch)
                          (begin
                            (write-char char-quote)
                            (write-char ch))
                          (write-char ch)))
                    field))))))
    (let loop
        ((record record))
      (cond
       ((null? record)
        (write-char record-sep))
       ((null? (cdr record))
        ;; Last field
        (write-field (car record))
        (write-char record-sep))
       (else
        (write-field (car record))
        (write-char field-sep)
        (loop (cdr record)))))))

(define (parse-char-field-arg options name default usage)
  (let ((value-str (alist-ref options name (lambda () default))))
    (if (= (string-length value-str) 1)
        (string-ref value-str 0)
        (usage))))

(receive (options operands before-exprs after-exprs usage)
         (parse-mp-args (command-line-arguments)
                        (list
                         (args:make-option (R record) (required: "CHARACTER")
                                           "Specify the record separater character")
                         (args:make-option (D delimiter) (required: "DELMIITER-CHAR")
                                           "Specify the delimiter character")
                         (args:make-option (T tsv) #:none
                                           "Set the delimiter character to a tab")
                         (args:make-option (Q field-quote) (required: "CHARACTER")
                                           "Specify the field quote character")
                         (args:make-option (q no-field-quote) #:none
                                           "Disable field quoting (not compatible with -c)")
                         (args:make-option (C char-quote) (required: "CHARACTER")
                                           "Specify the single character quote character")
                         (args:make-option (c no-char-quote) #:none
                                           "Disable character quoting (not compatibel with -q)"))
                        ""
                        "Read s-expressions (lists of strings and numbers) from standard input, and
convert them to CSV on standard output.")
         (unless (= (length operands) 0)
                 (usage))

         (let* ((ec (make-eval-context before-exprs '() after-exprs))
                (record-sep (parse-char-field-arg options 'record "\n" usage))
                (field-sep
                 (cond
                  ((assq 'tsv options) #\tab)
                  (else (parse-char-field-arg options 'delimiter "," usage))))
                (field-quote (if (assq 'no-field-quote options)
                                 #f
                                 (parse-char-field-arg options 'field-quote "\"" usage)))
                (char-quote (if (assq 'no-char-quote options)
                                #f
                                (parse-char-field-arg options 'char-quote "\\" usage)))
                (writer (make-csv-writer record-sep field-sep field-quote char-quote)))
           (when (and
                  (not field-quote)
                  (not char-quote))
             (usage))
           (for-each-input-datum
            (lambda (sexpr)
              (writer sexpr)))
           (without-input-port
            (eval-context-end-closure ec))))