;; original: http://poseur.com/darcs/magic/scm/xml.scm
;; See the LICENSE file there for copyright and licensing information.

;; modified by j.ursetto for Chicken and nested-lists

;;(use syntax-case matchable)
(declare
 (export xml literally
         string-concatenate-fragments for-each-fragment))

(define (entitize s)
  (string-translate* s '((">" . ">")
                         ("<" . "&lt;")
                         ("\"" . "&quot;")
                         ("&" . "&amp;"))))

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

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

(define (render-name&attrs name&attrs)
  (cond ((pair? name&attrs)
	 (list (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)
	       (list "<" (render-name&attrs name&attrs) " />")
	       (list "<" (render-name&attrs name&attrs) ">"
                     (apply xml sub-elts)
                     "</" (render-name name&attrs) ">"))))
        ((literal? elt) (literal-string elt))
	(else (with-output-to-string (cut write elt)))))

(define (xml . elts)
  (match elts
         (() '())
         ((e) (render-elt e))
         (_ (map render-elt elts))))

(define xml-join intersperse)

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

(define (literally . s)
  (match s
         (() '())
         ((s) (make-literal s))
         (s   (make-literal s))))

;; (define-syntax template
;;   (syntax-rules ()
;;     ((template (A1 A2 ...) PRELUDE ELT1 ELT2 ...)
;;      (lambda (A1 A2 ...) (list PRELUDE (xml ELT1 ELT2 ...))))))


;;; display

(define copy-bytes ##sys#copy-bytes)  ; from to offset1 offset2 bytes
(define byte-string-length string-length)

; it's odd, the recursive version is faster
(define (total-string-length fragments)
  (define (tsl L)
    (cond ((null? L) 0)
          ((pair? (car L))
           (+ (tsl (car L))
              (tsl (cdr L))))
          (else
           (+ (byte-string-length (car L))
              (tsl (cdr L))))))
  (tsl fragments))

;; Should probably allow chars.
(define (string-concatenate-fragments all)
  (let ((buf (make-string (total-string-length all))))
    (let loop ((fragments all) (pos 0))
      (cond ((null? fragments) pos)
            ((pair? (car fragments))
             (loop (cdr fragments)
                   (loop (car fragments) pos)))
            (else
             (let ((len (byte-string-length (car fragments))))
               (copy-bytes (car fragments) buf 0 pos len)
               (loop (cdr fragments) (+ pos len))))))
    buf))
 
(define (for-each-fragment proc all)
  (let loop ((fragments all))
    (cond ((null? fragments) (void))
          ((pair? (car fragments))
           (loop (car fragments))
           (loop (cdr fragments)))
          (else
           (proc (car fragments))
           (loop (cdr fragments))))))