;;;; cvs-out.impl -*- Hen -*-
;;;; Kon Lovett, Jun '17
;;;; *** included source file ***
;;Issues
;;
;;- missing explicit types for exports; too much '*' type
;;
(define-constant CRLF-STR "\r\n")
(define-constant LF-STR "\n")
(define-constant CR-STR "\r") ;old MacOS
(define *system-newline*
(cond-expand
(windows
CRLF-STR )
(unix
LF-STR )
(else
LF-STR ) ) )
(define-constant +newline-char-default+ #t) ;#t - <system> | #\n | ...
(define-constant +separator-char-default+ #\,)
(define-constant +quote-char-default+ #\") ;#f | #\" | ...
(define-constant +comment-char-default+ #\#) ;#f | #\# | ...
(define-constant +quote-doubling-escapes?-default+ #t)
(define-constant +quote-controls?-default+ #t)
(define-constant +always-quote?-default+ #t)
#|
(define-constant +sxml-top-symbol+ '|*TOP*|)
(define-constant +sxml-row-element-default+ 'row)
(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
|#
;;
;very loose : newline-char | separator-char | quote-char
;see "csv-xml.scm"
(define csv-writer-spec? alist?)
(define-check+error-type csv-writer-spec)
(define csv-writer? procedure?)
(define-check+error-type csv-writer)
;;
(define *default-writer-spec* (writer-spec-with-defaults '()))
(define (list->csv ls #!optional (writer-or-out (current-output-port)))
(let (
(writer
(cond
((csv-writer? writer-or-out)
writer-or-out )
((output-port? writer-or-out)
(make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
(else
(error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
(for-each writer ls) ) )
#|
;;
(define (list->sxml ls
#!optional
(row-element (sxml-row-element-default))
(column-elements (sxml-col-elements-default))
(writer-spec *default-writer-spec*))
(append!
`(,(sxml-top-symbol))
(map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
|#
;;
(define (writer-spec
#!key
(newline-char +newline-char-default+)
(separator-char +separator-char-default+)
(quote-char +quote-char-default+)
(comment-char +comment-char-default+)
(quote-doubling-escapes? +quote-doubling-escapes?-default+)
(quote-controls? +quote-controls?-default+)
(always-quote? +always-quote?-default+))
;FIXME checking the input types
`((newline-char . ,newline-char)
(separator-char . ,separator-char)
(quote-char . ,quote-char)
(comment-char . ,comment-char)
(quote-doubling-escapes? . ,quote-doubling-escapes?)
(quote-controls? . ,quote-controls?)
(always-quote? . ,always-quote?)) )
;;
(define (make-csv-writer out-or-str #!optional (writer-spec '()))
(let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
(make-spec-csv-writer out-or-str) ) )
(define (make-csv-writer-maker #!optional (writer-spec '()))
(let ((writer-spec
(writer-spec-with-defaults
(check-csv-writer-spec 'make-csv-writer-maker writer-spec)) ) )
(lambda (out-or-str)
(let (
(out
(cond
((string? out-or-str)
(open-output-file out-or-str) )
((output-port? out-or-str)
out-or-str )
(else
(error
'csv-writer-maker
"invalid output-port or string" out-or-str) ) ) ) )
(make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
;;
(define (make-csv-line-writer loc out writer-spec)
(let (
(writer-spec
(check-csv-writer-spec loc writer-spec) )
(newline-obj
(select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
(separator-char
(alist-ref 'separator-char writer-spec eq?) )
(quote-char
(alist-ref 'quote-char writer-spec eq?) )
(comment-char
(alist-ref 'comment-char writer-spec eq?) )
(quote-doubling-escapes?
(alist-ref 'quote-doubling-escapes? writer-spec eq?) )
(quote-controls?
(alist-ref 'quote-controls? writer-spec eq?) )
(always-quote?
(alist-ref 'always-quote? writer-spec eq?) ) )
;
(let* (
(quote-char-str (unicode-char->string quote-char) )
(quote-char-str-2 (string-append quote-char-str quote-char-str)) )
;
(define (csv-line-object->string obj)
;
(define (quote-doubling? str)
(and quote-doubling-escapes? (string-index str quote-char)) )
;
(define (quoting? str)
(or
always-quote?
(quote-doubling? str)
(and separator-char (string-index str separator-char))
(and quote-controls? (string-index str char-set:iso-control))) )
;
(type-case obj
((char)
(csv-line-object->string (unicode-char->string obj)) )
((symbol)
(csv-line-object->string (symbol->string obj)) )
((string)
(if (and quote-char (quoting? obj))
(let (
(str
(if (quote-doubling? obj)
(string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
obj ) ) )
;
(conc quote-char str quote-char) )
obj ) )
(number
(csv-line-object->string (number->string obj)) )
(else
(csv-line-object->string (->string obj)) ) ) )
;
(lambda (obj)
(let (
;build row to output as a string with a line-ending sequence
(lin
;comment desired?
(if (list? obj)
;row data
(let ((qstrs (map csv-line-object->string (check-list loc obj))))
(apply
conc
(append!
(intersperse qstrs separator-char)
`(,newline-obj))) )
;are we supposed to do comments?
(if comment-char
(conc comment-char obj newline-obj)
obj
#;
(begin
(warning loc "comments not active" obj writer-spec)
"" ) ) ) ) )
;
(display lin out) ) ) ) ) )
;;
(define (select-newline-object loc spec)
(case spec
((cr)
#\return )
((lf)
#\newline )
((crlf)
CRLF-STR )
(else
*system-newline* ) ) )
;;
(define (writer-spec-with-defaults writer-spec)
`((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
(separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
(quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
(comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
(quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
(quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
(always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
#|
;;
(define (list->sxml-element ls row-element col-elements writer-spec)
(if (list? ls)
;row data
`(,row-element ,@(map list col-elements (map ->string ls)))
;are we supposed to do comments?
(if (alist-ref 'comment-char writer-spec eq?)
`(*COMMENT* ,(->string ls))
ls ) ) )
(define (make-sxml-col-symbol n)
(string->symbol (string-append "col-" (number->string n))) )
(define +sxml-col-elements-default+
(map make-sxml-col-symbol (sxml-col-iota)) )
(define (sxml-top-symbol)
+sxml-top-symbol+ )
(define (sxml-row-element-default)
+sxml-row-element-default+ )
(define (sxml-col-elements-default)
+sxml-col-elements-default+ )
(define (sxml-col-iota)
(iota +sxml-col-elements-limit-default+) )
#;
(define (sxml-col-iota)
(do ((i 0 add1)
(ls '() (cons (make-sxml-col-symbol i) ls)) )
((= i +sxml-col-elements-limit-default+) ls) ) )
|#