source: project/release/4/csv-xml/trunk/csv-out.impl @ 34889

Last change on this file since 34889 was 34889, checked in by Kon Lovett, 4 years ago

fix quoting when sep char , fix quoting when # or ???

File size: 8.0 KB
Line 
1;;;; cvs-out.impl  -*- Hen -*-
2;;;; Kon Lovett, Jun '17
3
4;;;; *** included source file ***
5
6;;Issues
7;;
8;;- missing explicit types for exports; too much '*' type
9
10;;
11
12(define-constant CRLF-STR "\r\n")
13(define-constant LF-STR "\n")
14(define-constant CR-STR "\r") ;old MacOS
15
16(define *system-newline*
17  (cond-expand
18    (windows
19      CRLF-STR )
20    (unix
21      LF-STR )
22    (else
23      LF-STR ) ) )
24
25(define-constant +newline-char-default+ #t)               ;#t - <system> | #\n | ...
26(define-constant +separator-char-default+ #\,)
27(define-constant +quote-char-default+ #\")                ;#f | #\" | ...
28(define-constant +comment-char-default+ #\#)              ;#f | #\# | ...
29(define-constant +quote-doubling-escapes?-default+ #t)
30(define-constant +quote-controls?-default+ #t)
31(define-constant +always-quote?-default+ #t)
32
33#|
34(define-constant +sxml-top-symbol+ '|*TOP*|)
35(define-constant +sxml-row-element-default+ 'row)
36(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
37|#
38
39;;
40
41;very loose : newline-char | separator-char | quote-char
42;see "csv-xml.scm"
43(define csv-writer-spec? alist?)
44(define-check+error-type csv-writer-spec)
45
46(define csv-writer? procedure?)
47(define-check+error-type csv-writer)
48
49;;
50
51(define *default-writer-spec* (writer-spec-with-defaults '()))
52
53(define (list->csv ls #!optional (writer-or-out (current-output-port)))
54  (let (
55      (writer
56        (cond
57          ((csv-writer? writer-or-out)
58            writer-or-out )
59          ((output-port? writer-or-out)
60            (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
61          (else
62            (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
63    (for-each writer ls) ) )
64
65#|
66;;
67
68(define (list->sxml ls
69          #!optional
70          (row-element (sxml-row-element-default))
71          (column-elements (sxml-col-elements-default))
72          (writer-spec *default-writer-spec*))
73  (append!
74    `(,(sxml-top-symbol))
75    (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
76|#
77
78;;
79
80(define (writer-spec
81          #!key
82          (newline-char +newline-char-default+)
83          (separator-char +separator-char-default+)
84          (quote-char +quote-char-default+)
85          (comment-char +comment-char-default+)
86          (quote-doubling-escapes? +quote-doubling-escapes?-default+)
87          (quote-controls? +quote-controls?-default+)
88          (always-quote? +always-quote?-default+))
89  ;FIXME checking the input types
90  `((newline-char . ,newline-char)
91    (separator-char . ,separator-char)
92    (quote-char . ,quote-char)
93    (comment-char . ,comment-char)
94    (quote-doubling-escapes? . ,quote-doubling-escapes?)
95    (quote-controls? . ,quote-controls?)
96    (always-quote? . ,always-quote?)) )
97
98;;
99
100(define (make-csv-writer out-or-str #!optional (writer-spec '()))
101  (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
102    (make-spec-csv-writer out-or-str) ) )
103
104(define (make-csv-writer-maker #!optional (writer-spec '()))
105  (let ((writer-spec
106          (writer-spec-with-defaults
107            (check-csv-writer-spec 'make-csv-writer-maker writer-spec)) ) )
108    (lambda (out-or-str)
109      (let (
110          (out
111            (cond
112              ((string? out-or-str)
113                (open-output-file out-or-str) )
114              ((output-port? out-or-str)
115                out-or-str )
116              (else
117                (error
118                  'csv-writer-maker
119                  "invalid output-port or string" out-or-str) ) ) ) )
120        (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
121
122;;
123
124(define (make-csv-line-writer loc out writer-spec)
125  (let (
126    (writer-spec
127      (check-csv-writer-spec loc writer-spec) )
128    (newline-obj
129      (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
130    (separator-char
131      (alist-ref 'separator-char writer-spec eq?) )
132    (quote-char
133      (alist-ref 'quote-char writer-spec eq?) )
134    (comment-char
135      (alist-ref 'comment-char writer-spec eq?) )
136    (quote-doubling-escapes?
137      (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
138    (quote-controls?
139      (alist-ref 'quote-controls? writer-spec eq?) )
140    (always-quote?
141      (alist-ref 'always-quote? writer-spec eq?) ) )
142    ;
143    (let* (
144      (quote-char-str (unicode-char->string quote-char) )
145      (quote-char-str-2 (string-append quote-char-str quote-char-str)) )
146      ;
147      (define (csv-line-object->string obj)
148        ;
149        (define (quote-doubling? str)
150          (and quote-doubling-escapes? (string-index str quote-char)) )
151        ;
152        (define (quoting? str)
153          (or
154            always-quote?
155            (quote-doubling? str)
156            (and separator-char (string-index str separator-char))
157            (and quote-controls? (string-index str char-set:iso-control))) )
158        ;
159        (type-case obj
160          ((char)
161            (csv-line-object->string (unicode-char->string obj)) )
162          ((symbol)
163            (csv-line-object->string (symbol->string obj)) )
164          ((string)
165            (if (and quote-char (quoting? obj))
166              (let (
167                (str
168                  (if (quote-doubling? obj)
169                    (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
170                    obj ) ) )
171                ;
172                (conc quote-char str quote-char) )
173              obj ) )
174          (number
175            (csv-line-object->string (number->string obj)) )
176          (else
177            (csv-line-object->string (->string obj)) ) ) )
178      ;
179      (lambda (obj)
180        (let (
181          ;build row to output as a string with a line-ending sequence
182          (lin
183            ;comment desired?
184            (if (list? obj)
185              ;row data
186              (let ((qstrs (map csv-line-object->string (check-list loc obj))))
187                (apply
188                  conc
189                  (append!
190                    (intersperse qstrs separator-char)
191                    `(,newline-obj))) )
192              ;are we supposed to do comments?
193              (if comment-char
194                (conc comment-char obj newline-obj)
195                obj
196                #;
197                (begin
198                  (warning loc "comments not active" obj writer-spec)
199                  "" ) ) ) ) )
200            ;
201            (display lin out) ) ) ) ) )
202
203;;
204
205(define (select-newline-object loc spec)
206  (case spec
207    ((cr)
208      #\return )
209    ((lf)
210      #\newline )
211    ((crlf)
212      CRLF-STR )
213    (else
214      *system-newline* ) ) )
215
216;;
217
218(define (writer-spec-with-defaults writer-spec)
219  `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
220    (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
221    (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
222    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
223    (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
224    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
225    (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
226
227#|
228;;
229
230(define (list->sxml-element ls row-element col-elements writer-spec)
231  (if (list? ls)
232    ;row data
233    `(,row-element ,@(map list col-elements (map ->string ls)))
234    ;are we supposed to do comments?
235    (if (alist-ref 'comment-char writer-spec eq?)
236      `(*COMMENT* ,(->string ls))
237      ls ) ) )
238
239(define (make-sxml-col-symbol n)
240  (string->symbol (string-append "col-" (number->string n))) )
241
242(define +sxml-col-elements-default+
243  (map make-sxml-col-symbol (sxml-col-iota)) )
244
245(define (sxml-top-symbol)
246  +sxml-top-symbol+ )
247
248(define (sxml-row-element-default)
249  +sxml-row-element-default+ )
250
251(define (sxml-col-elements-default)
252  +sxml-col-elements-default+ )
253
254(define (sxml-col-iota)
255  (iota +sxml-col-elements-limit-default+) )
256#;
257(define (sxml-col-iota)
258  (do ((i 0 add1)
259       (ls '() (cons (make-sxml-col-symbol i) ls)) )
260      ((= i +sxml-col-elements-limit-default+) ls) ) )
261|#
Note: See TracBrowser for help on using the repository browser.