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

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

re-flow

File size: 7.9 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 quote-controls? (string-index str char-set:iso-control))) )
157        ;
158        (type-case obj
159          ((char)
160            (csv-line-object->string (unicode-char->string obj)) )
161          ((symbol)
162            (csv-line-object->string (symbol->string obj)) )
163          ((string)
164            (if (and quote-char (quoting? obj))
165              (let (
166                (str
167                  (if (quote-doubling? obj)
168                    (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
169                    obj ) ) )
170                ;
171                (conc quote-char str quote-char) )
172              obj ) )
173          (number
174            (csv-line-object->string (number->string obj)) )
175          (else
176            (->string obj) ) ) )
177      ;
178      (lambda (obj)
179        (let (
180          ;build row to output as a string with a line-ending sequence
181          (lin
182            ;comment desired?
183            (if (list? obj)
184              ;row data
185              (let ((qstrs (map csv-line-object->string (check-list loc obj))))
186                (apply
187                  conc
188                  (append!
189                    (intersperse qstrs separator-char)
190                    `(,newline-obj))) )
191              ;are we supposed to do comments?
192              (if comment-char
193                (conc comment-char obj newline-obj)
194                obj
195                #;
196                (begin
197                  (warning loc "comments not active" obj writer-spec)
198                  "" ) ) ) ) )
199            ;
200            (display lin out) ) ) ) ) )
201
202;;
203
204(define (select-newline-object loc spec)
205  (case spec
206    ((cr)
207      #\return )
208    ((lf)
209      #\newline )
210    ((crlf)
211      CRLF-STR )
212    (else
213      *system-newline* ) ) )
214
215;;
216
217(define (writer-spec-with-defaults writer-spec)
218  `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
219    (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
220    (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
221    (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
222    (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
223    (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
224    (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
225
226#|
227;;
228
229(define (list->sxml-element ls row-element col-elements writer-spec)
230  (if (list? ls)
231    ;row data
232    `(,row-element ,@(map list col-elements (map ->string ls)))
233    ;are we supposed to do comments?
234    (if (alist-ref 'comment-char writer-spec eq?)
235      `(*COMMENT* ,(->string ls))
236      ls ) ) )
237
238(define (make-sxml-col-symbol n)
239  (string->symbol (string-append "col-" (number->string n))) )
240
241(define +sxml-col-elements-default+
242  (map make-sxml-col-symbol (sxml-col-iota)) )
243
244(define (sxml-top-symbol)
245  +sxml-top-symbol+ )
246
247(define (sxml-row-element-default)
248  +sxml-row-element-default+ )
249
250(define (sxml-col-elements-default)
251  +sxml-col-elements-default+ )
252
253(define (sxml-col-iota)
254  (iota +sxml-col-elements-limit-default+) )
255#;
256(define (sxml-col-iota)
257  (do ((i 0 add1)
258       (ls '() (cons (make-sxml-col-symbol i) ls)) )
259      ((= i +sxml-col-elements-limit-default+) ls) ) )
260|#
Note: See TracBrowser for help on using the repository browser.