main.ss
#lang scheme

(require (for-syntax (planet synx/displayz)))
(require (for-syntax "insert-prefix.ss"))

(define (write-element write value)
  (if (procedure? value) (value write)
      (write (encode value))))

(define (encode value)
  (cond
    [(keyword? value) (keyword->string value)]
    [(symbol? value) (symbol->string value)]
    [(string? value) value]
    [(bytes? value) (bytes->string/utf-8 value)] ; err...
    [(number? value) (number->string value)]
    [else (error (format "No XML encoding for ~s" value))]))
      
(define start-element
  (λ (attrs values name empty?)
    (string-append
     "<" (encode name)
     (if (null? attrs) ""
         (string-append 
          " "
          (string-join (map (λ (a v) (string-append (encode a) "=\"" (encode v) "\"")) attrs values) " ")))
     (if empty? 
         " />"
         ">"))))

(define (end-element name)
  (string-append "</" (encode name) ">\n"))

(define (cdata data)
  (string-append "<!--/* <![CDATA[ */\n" (encode data) "\n/* ]]> */-->"))

(define writer
  (make-keyword-procedure
   (λ (attrs values name . body)
     (λ (write)
       (if (eq? name 'lit) body
           (begin
             (write (start-element attrs values name (null? body)))
             ; notice that the start tag gets written before the body is ever
             ; processed.
             (for-each
              (λ (item) (write-element write item))
              body)
             (when (not (null? body)) (write (end-element name)))))))))

(define (joiner l)
  (λ (write)
    (map (λ (item) (write-element write item)) l)))
  
(define-syntax gen
  (λ (form)
    (datum->syntax
     form
     ; using #'writer not 'writer is VERY IMPORTANT for module renaming
     (insert-prefix (cadr (syntax->datum form)) #'writer #'joiner)
     form)))

(provide gen writer joiner encode cdata)