;; original: http://poseur.com/darcs/magic/scm/xml.scm
;; See the LICENSE file there for copyright and licensing information.
;; However, this version is almost completely rewritten.

;; modified by j.ursetto for Chicken and nested-lists
;; originally used nested lists for attrs; but this
;; means you have a flat source doc.  changed to @.
;; simpler attribute rendering.

;; Switched from @ plist -- e.g. (@ color "red" id "picker") to
;; (@ (color "red") (id "picker")).  It's noisier, but I've found
;; there are several times I wanted to use the flattening and
;; combining behavior of the tree on attribute values, which is
;; impossible when restricted to a single value.  This way you
;; can do (@ (href ,(intersperse '(3e8.org hacks dc) "/"))) without
;; having to manually string-append.  To make it less noisy,
;; you could just accept pairs as values instead-- (@ href ("hacks" "/" "dc")).

;; flaws: automatically using < /> for empty tags is incorrect for
;; certain tags such as p.  <p></p> not <p />.  However, you can
;; use (p "") to remedy.

;; Use #t or #f for value of boolean attribute such as 'readonly'.
;; May also just specify the attribute key itself, e.g. (boolean).

(declare
 (export xml xml-tree xml-comment literally
         tree->string for-each-fragment))

(use srfi-1)  ;; remove

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

(define (render-attr-values v)
  (map render-attr-value v))

;; Result must be a fragment (a string).
(define (render-attr-value x)
  (cond ((null? x)
         "")
        ((literal? x)
         (literal-string x))
        ((pair? x)
         (render-attr-values x))
        (else 
         (entitize (->string x)))))

(define render-attr
  (match-lambda
   (()
    "")
   ((k)
    (symbol->string k))
   ((k #t)
    (symbol->string k))
   ((k #f)
    "")
   ((k . v)
    (list (symbol->string k)
          "=\""
          (render-attr-values v)
          "\""))))

(define (render-name+attrs name attrs)
  (cond ((pair? attrs)
	 (intersperse (cons (symbol->string name)
                            (filter (lambda (x) (not (equal? x "")))
                                    (map render-attr attrs)))
                      " "))
	(else (symbol->string name))))

(define (render-name name)
  (symbol->string name))

(define (render-list L)
  (cond ((symbol? (car L))
         (let ((name (car L))
               (body (cdr L))
               (attrs '()))
           (when (and (pair? body)
                      (pair? (car body))
                      (eq? '@ (caar body)))
             (set! attrs (cdar body))
             (set! body (cdr body)))
           (if (null? body)
               (list "<" (render-name+attrs name attrs) " />")
               (list "<" (render-name+attrs name attrs) ">"
                     (map render-elt body)
                     "</" (render-name name) ">"))))
        (else (map render-elt L))))

(define (render-elt elt)
  (cond ((null? elt) "")
        ((string? elt) (entitize elt))
        ((list? elt) (render-list elt))
        ((literal? elt) (literal-string elt))
        ((procedure? elt) (render-elt (elt)))
        (else (with-output-to-string (cut write elt)))))

(define (xml-tree . elts)
  (map render-elt elts))
(define (xml . elts)
  (tree->string (apply xml-tree elts)))

(define xml-join intersperse)
(define (xml-comment . elts)
  (literally "<!-- "
             (apply xml-tree elts)
             " -->\n"))

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

 (define-record-printer (literal L port)
    (fprintf port "#<literal ~S>" (literal-string L)))


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

;;; 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 sometimes faster
(define (total-string-length fragments)
  (define (tsl L)
    (cond ((null? L) 0)
          ((null? (car L))
           (tsl (cdr L)))
          ((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 (tree->string tree)
  (let ((buf (make-string (total-string-length tree))))
    (let loop ((fragments tree) (pos 0))
      (cond ((null? fragments) pos)
            ((null? (car fragments))
             (loop (cdr 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))))))