;;; -*- mode: scheme; scheme48-package: xml -*-

;;; See the LICENSE file for copyright and licensing information.

(define (entitize s)
  (let ((c (string-cursor s)))
    (let loop ()
      (cond ((cursor-last? c) (cursor-string c))
	    (else (case (cursor-forward c)
		    ((#\>) (cursor-replace! c ">"))
		    ((#\<) (cursor-replace! c "&lt;"))
		    ((#\") (cursor-replace! c "&quot;"))
		    ((#\&) (cursor-replace! c "&amp;")))
		  (loop))))))

(define (render-attr-name attrs s)
  (cond ((null? attrs) 
	 s)
        (else
         (render-attr-value (cdr attrs)
                            (string-append s
                                           " "
                                           (symbol->string (car attrs))
                                           "=\"")))))

(define (render-attr-value attrs s)
  (cond ((null? attrs) (string-append s "\""))
	(else
	  (render-attr-name (cdr attrs)
			       (string-append s
					        (entitize (car attrs))
						  "\"")))))

(define (render-name&attrs name&attrs)
  (cond ((pair? name&attrs)
	 (string-append (symbol->string (car name&attrs))
			(render-attr-name (cdr name&attrs) "")))
	(else (symbol->string name&attrs))))

(define (render-name name&attrs)
  (cond ((pair? name&attrs)
         (symbol->string (car name&attrs)))
        (else (symbol->string name&attrs))))

(define (render-elt elt)
  (cond ((string? elt) (entitize elt))
	((list? elt)
	 (let ((name&attrs (car elt))
	       (sub-elts (cdr elt)))
	   (if (null? sub-elts)
	       (string-append "<"
			      (render-name&attrs name&attrs)
			      " />")
	       (string-append "<"
			      (render-name&attrs name&attrs)
			      ">"
			      (apply xml sub-elts)
			      "</"
			      (render-name name&attrs)
			      ">"))))
        ((literal? elt) (literal-string elt))
	(else (let ((p (make-string-output-port)))
		(write elt p)
		(string-output-port-output p)))))

(define (xml . elts)
  (apply string-append
	 (map (lambda (elt) (render-elt elt)) elts)))

(define (xml-join list separator)
  (fold-right
   (lambda (item rest)
      (cons item
	    (if (null? rest)
		'()
		(cons separator rest))))
   '()
   list))

(define-record-type literal :literal
  (make-literal s)
  literal?
  (s literal-string set-literal-string!))

(define (literally . s)
  (make-literal (apply string-append s)))

(define-syntax template
  (syntax-rules ()
    ((template (A1 A2 ...) PRELUDE ELT1 ELT2 ...)
     (lambda (A1 A2 ...) (string-append PRELUDE (xml ELT1 ELT2 ...))))))