;;;; cvs-out.impl  -*- Hen -*-
;;;; Kon Lovett, Jun '17

;;;; *** included source file ***

;;Issues
;;
;;- missing explicit types for exports

;;

(define-constant +newline-default+ #t)  ;#t - <system>
(define-constant +separator-char+ #\,)
(define-constant +quote-char+ #\")

(define-constant CRLF-STR "\r\n")
(define-constant LF-STR "\n")
(define-constant CR-STR "\r") ;old MacOS

(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)

(define (make-sxml-col-symbol n)
  (string->symbol (string-append "col-" (number->string n))) )

;;

;very loose : newline | separator-char | quote-char
(define csv-writer-spec? alist?)
(define-check+error-type csv-writer-spec)

(define csv-writer? procedure?)
(define-check+error-type csv-writer)

;;

(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)
              (csv-line-writer 'list->csv
                writer-or-out (writer-spec-with-defaults '())) )
            (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)))
  (append!
    `(,(sxml-top-symbol))
    (map (cut list->sxml-element <> row-element column-elements) ls)) )

;;

(define (writer-spec
          #!key
          (newline +newline-default+)
          (separator-char +separator-char+)
          (quote-char +quote-char+))
  `((newline . ,newline)
    (separator-char . ,separator-char)
    (quote-char . ,quote-char)) )

;;

(define (make-csv-writer out-or-str #!optional writer-spec)
  (let ((actual-make-csv-writer (make-csv-writer-maker writer-spec)))
    (actual-make-csv-writer out-or-str) ) )

(define (make-csv-writer-maker 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 stirng" out-or-str) ) ) ) )
        (csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )

;;

(define (csv-line-writer loc out writer-spec)
;(print 'csv-line-writer " " loc " " out " " writer-spec)
  (let* ((writer-spec
          (check-csv-writer-spec loc writer-spec) )
         (newline
          (select-newline loc (cdr (assq 'newline writer-spec))) )
         (separator-char
          (cdr (assq 'separator-char writer-spec)) )
         (quote-char
          (let ((obj (assq 'quote-char writer-spec)))
            (if (pair? obj)
              (cdr obj)
              obj ) ) ) )
    (lambda (objs)
      (check-list loc objs)
      (let* (
          (strs
            (map ->string objs) )
          (qstrs
            (if quote-char
              (map (cut conc quote-char <> quote-char) strs)
              strs ) )
           (str
            (apply conc (append! (intersperse qstrs separator-char) `(,newline))) ) )
        (display str out) ) ) ) )

;;

(define (list->sxml-element ls row-element col-elements)
  `(,row-element ,@(map list col-elements ls)) )

;;

(define *system-newline*
  (cond-expand
    (windows
      CRLF-STR )
    (unix
      LF-STR )
    (else
      LF-STR ) ) )

(define (select-newline loc spec)
  (case spec
    ((cr)
      #\return )
    ((lf)
      #\newline )
    ((crlf)
      CRLF-STR )
    (else
      *system-newline*
      #; ;be generous - THIS IS NOT A EITHER/OR - only 1 is right
      (if (and (boolean? spec) spec)
        *system-newline*
        (error loc "invalid newline specification" spec) ) ) ) )

;;

(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) ) )

(define (writer-spec-with-defaults writer-spec)
  (let ((newline
          (assq 'newline writer-spec) )
        (separator-char
          (assq 'separator-char writer-spec) )
        (quote-char
          (let ((obj (assq 'quote-char writer-spec)))
            (if (pair? obj)
              (cdr obj)
              obj ) ) ) )
    `((newline . ,(or newline +newline-default+))
      (separator-char . ,(or separator-char +separator-char+))
      (quote-char . ,(or quote-char +quote-char+))) ) )