From f28168a2a6cee4e3821f46efae784d35b99bea83 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Sat, 2 Nov 2024 23:10:49 +0900
Subject: [PATCH] Adding csv-writer support.

---
 lib/chibi/csv-test.sld | 19 +++++++++++
 lib/chibi/csv.scm      | 75 ++++++++++++++++++++++++++++++++++++++++++
 lib/chibi/csv.sld      |  5 +--
 3 files changed, 97 insertions(+), 2 deletions(-)

diff --git a/lib/chibi/csv-test.sld b/lib/chibi/csv-test.sld
index 08448035..41bc5c05 100644
--- a/lib/chibi/csv-test.sld
+++ b/lib/chibi/csv-test.sld
@@ -9,6 +9,11 @@
     (define string->csv
       (opt-lambda (str (reader (csv-read->list)))
         (reader (open-input-string str))))
+    (define csv->string
+      (opt-lambda (row (writer (csv-writer)))
+        (let ((out (open-output-string)))
+          (writer row out)
+          (get-output-string out))))
     (define (run-tests)
       (test-begin "(chibi csv)")
       (test-assert (eof-object? (string->csv "")))
@@ -73,4 +78,18 @@ Paris,48°51′24″N,2°21′03″E"))
                      (longitude "2°21′03″E")))
            ((csv->sxml 'city '(name latitude longitude))
             (open-input-string city-csv))))
+      (test "1997,Ford,E350\n"
+          (csv->string '("1997" "Ford" "E350")))
+      (test "1997,Ford,E350,\"Super, luxurious truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, luxurious truck")))
+      (test "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, \"luxurious\" truck")))
+      (test "1997,Ford,E350,\"Go get one now\nthey are going fast\"\n"
+          (csv->string
+           '("1997" "Ford" "E350" "Go get one now\nthey are going fast")))
+      (test "1997,Ford,E350\n"
+          (csv->string '(1997 "Ford" E350)))
+      (test "1997,\"Ford\",\"E350\"\n"
+          (csv->string '(1997 "Ford" E350)
+                       (csv-writer (csv-grammar '((quote-non-numeric? . #t))))))
       (test-end))))
diff --git a/lib/chibi/csv.scm b/lib/chibi/csv.scm
index eaa95fbf..a3a68354 100644
--- a/lib/chibi/csv.scm
+++ b/lib/chibi/csv.scm
@@ -84,6 +84,8 @@
 (define default-tsv-grammar
   (csv-grammar '((separator-chars #\tab) (quote-char . #f))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 ;;> \section{CSV Parsers}
 
 ;;> Parsers are low-level utilities to perform operations on records a
@@ -375,3 +377,76 @@
     (opt-lambda ((in (current-input-port)))
       (cons '*TOP*
             (csv->list (csv-read->sxml row-name column-names parser) in)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{CSV Writers}
+
+(define (write->string obj)
+  (let ((out (open-output-string)))
+    (write obj out)
+    (get-output-string out)))
+
+(define (csv-grammar-char-needs-quoting? grammar ch)
+  (or (eqv? ch (csv-grammar-quote-char grammar))
+      (eqv? ch (csv-grammar-escape-char grammar))
+      (memv ch (csv-grammar-separator-chars grammar))
+      (eqv? ch (csv-grammar-record-separator grammar))
+      (memv ch '(#\newline #\return))))
+
+(define (csv-write-quoted obj out grammar)
+  (let ((in (open-input-string (if (string? obj) obj (write->string obj)))))
+    (write-char (csv-grammar-quote-char grammar) out)
+    (let lp ()
+      (let ((ch (read-char in)))
+        (cond
+         ((eof-object? ch))
+         ((or (eqv? ch (csv-grammar-quote-char grammar))
+              (eqv? ch (csv-grammar-escape-char grammar)))
+          (cond
+           ((and (csv-grammar-quote-doubling-escapes? grammar)
+                 (eqv? ch (csv-grammar-quote-char grammar)))
+            (write-char ch out))
+           ((csv-grammar-escape-char grammar)
+            => (lambda (esc) (write-char esc out)))
+           (else (error "no quote defined for" ch grammar)))
+          (write-char ch out)
+          (lp))
+         (else
+          (write-char ch out)
+          (lp)))))
+    (write-char (csv-grammar-quote-char grammar) out)))
+
+(define csv-writer
+  (opt-lambda ((grammar default-csv-grammar))
+    (opt-lambda (row (out (current-output-port)))
+      (let lp ((ls row) (first? #t))
+        (when (pair? ls)
+          (unless first?
+            (write-char (car (csv-grammar-separator-chars grammar)) out))
+          (if (or (and (csv-grammar-quote-non-numeric? grammar)
+                       (not (number? (car ls))))
+                  (and (string? (car ls))
+                       (string-any
+                        (lambda (ch) (csv-grammar-char-needs-quoting? grammar ch))
+                        (car ls)))
+                  (and (not (string? (car ls)))
+                       (not (number? (car ls)))
+                       (not (symbol? (car ls)))))
+              (csv-write-quoted (car ls) out grammar)
+              (display (car ls) out))
+          (lp (cdr ls) #f)))
+      (write-string
+       (case (csv-grammar-record-separator grammar)
+         ((crlf) "\r\n")
+         ((lf lax) "\n")
+         ((cr) "\r")
+         (else (string (csv-grammar-record-separator grammar))))
+       out))))
+
+(define csv-write
+  (opt-lambda ((writer (csv-writer)))
+    (opt-lambda (rows (out (current-output-port)))
+      (for-each
+       (lambda (row) (writer row out))
+       rows))))
diff --git a/lib/chibi/csv.sld b/lib/chibi/csv.sld
index f4df593d..6913f78c 100644
--- a/lib/chibi/csv.sld
+++ b/lib/chibi/csv.sld
@@ -1,9 +1,10 @@
 
 (define-library (chibi csv)
-  (import (scheme base) (srfi 227))
+  (import (scheme base) (scheme write) (srfi 130) (srfi 227))
   (export csv-grammar csv-parser csv-grammar?
           default-csv-grammar default-tsv-grammar
           csv-read->list csv-read->vector  csv-read->fixed-vector
           csv-read->sxml
-          csv-fold csv-map csv->list csv-for-each csv->sxml)
+          csv-fold csv-map csv->list csv-for-each csv->sxml
+          csv-writer csv-write)
   (include "csv.scm"))