#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)] [(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)))
(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
(insert-prefix (cadr (syntax->datum form)) #'writer #'joiner)
form)))
(provide gen writer joiner encode cdata)