;; TODO: possibly change xml/xml-tree to accept only a single argument.
;; TODO: Benchmark symbol->string/shared
;; TODO: Benchmark optimizations
;; TODO: Benchmark this in general...
;;; Attribute syntax
;; Attribute lists look like (@ ...) and must be
;; in cadr position. Both alists and plists may be used to describe
;; attribute key-value pairs.
;; Example syntax: (@ (K V ...) K V (K V ...))
;; K may be a symbol or a keyword. V may be any object that can
;; be stringified with ->string, an xml-literal, a null list (equivalent to
;; empty string), or a pair. If it is a pair, its elements are treated
;; as attribute values and concatenated together. In alist syntax,
;; you may specify more than one V for a given K, which is handled
;; like the pair in the previous sentence.
;; Use #t or #f for the value of a boolean attribute such as
;; 'readonly', or (in alist syntax only) omit the value as an
;; alternative to #t: (readonly). As XML does not support attribute
;; minimization, a boolean true attribute is rendered with key K and
;; value K, e.g. readonly="readonly".
;; `(input (@ readonly: ,(read-only? x)
;; type: text
;; size: 3
;; onblur: (,js-validation-func "(this.value)" )))
;; `(a (@ (href "http://" ,(intersperse '(3e8.org hacks dc) "/"))
;; (style "text-decoration: none"))
;; "Dreamcast hacks")
;;; main
(declare
(export xml xml-tree xml-literal xml-comment xml-inline-comment
tree->string for-each-fragment
block-element? minimize-element?)
;; usual-integrations, optimizations?
)
(use matchable) ;; chicken 4
;; Use original copy of symbol's interned string.
(define (symbol->string/shared s)
(##sys#check-symbol s 'symbol->string/shared)
(##sys#symbol->string s))
;;; Empty tags, block tags
;; block-element? and minimize-element? are parameterized procedures
;; which operate on generic identifiers (tag names). If block-element?
;; returns #t, the renderer prepends a newline to the open tag.
;; Inline elements are untouched to avoid altering whitespace.
;; If minimize-element? returns #t, AND the element body is empty,
;; the element is rendered in minimized form -- e.g. .
;; Otherwise empty bodies look like: .
;; By default, these parameters are set up to mimic XHTML.
;; See sections C.2 and C.3 in http://www.w3.org/TR/xhtml1/#guidelines.
(define xhtml-empty-elements
'(base meta link frame hr br basefont param img area input isindex col))
;; (define xhtml-inline-elements
;; '(a abbr acronym cite code dfn em font kbd q
;; samp strong var b big i small strike sub sup tt u blink span))
(define xhtml-block-elements
'(p h1 h2 h3 h4 h5 h6
div ul ol dl menu dir
pre hr blockquote address center
isindex fieldset table
head html title script style meta link base
li dt dd tr td))
(define block-element?
(make-parameter (lambda (x) (memq x xhtml-block-elements))))
(define minimize-element?
(make-parameter (lambda (x) (memq x xhtml-empty-elements))))
;;; rendering
(define (escape s)
(string-translate* s '((">" . ">")
("<" . "<")
("\"" . """)
("&" . "&"))))
(define-inline (render-attribute-values v)
(map render-attribute-value v))
;; Result must be a fragment.
(define (render-attribute-value x)
(cond ((null? x)
"")
((literal? x)
(literal-string x))
((pair? x)
(render-attribute-values x))
(else
(escape (->string x)))))
;; Result must be a pair or null.
(define render-attribute-pair
(match-lambda
((k)
(render-attribute-pair (list k k)))
((k #t)
(render-attribute-pair (list k k)))
((k #f)
'())
((k . v)
(list (symbol->string k)
"=\""
(render-attribute-values v)
"\""))))
(define (render-attributes A)
(cond ((null? A) '())
((null? (car A))
(render-attributes (cdr A)))
((pair? (car A))
(let ((pair (render-attribute-pair (car A))))
(if (null? pair)
(render-attributes (cdr A))
(cons " " (cons pair (render-attributes (cdr A)))))))
(else
(match A
((k v rest ...)
(let ((pair (render-attribute-pair (list k v))))
(if (null? pair)
(render-attributes (cddr A))
(cons " " (cons pair (render-attributes (cddr A)))))))
((k)
(error 'render-attributes "missing value for key" k))))))
(define-inline (render-gi name)
(symbol->string name))
(define (render-list L)
(define (render name attrs body)
(let ((open< (if ((block-element?) name) "\n<" "<")))
(if (and (null? body)
((minimize-element?) name))
(list open< (render-gi name) (render-attributes attrs) " />")
(list open< (render-gi name) (render-attributes attrs) ">"
(map render-element body)
""))))
(cond ((symbol? (car L))
(let ((name (car L)))
(cond ((eqv? name ':) ; handle zmarkup-style colon item by interspersing spaces
;; (string-intersperse (map xml (cdr L)) ; It should be fine to flatten this to a string immediately.
;; " "))
(intersperse (map render-element (cdr L)) ; But we stick with the paradigm, the list form.
" "))
((eqv? name '+) ; handle zmarkup-style concat by eliding +
(render-list (cdr L)))
((eqv? name '&)
(list "&" (cadr L) ";"))
(else
(let ((body (cdr L))
(attrs '()))
(if (and (pair? body)
(pair? (car body))
(eq? '@ (caar body)))
(render name (cdar body) (cdr body))
(render name '() body)))))))
(else (map render-element L))))
(define (render-element elt)
(cond ((null? elt) '())
((not elt) #f)
((string? elt) (escape elt))
((list? elt) (render-list elt))
((literal? elt) (literal-string elt))
((procedure? elt) (render-element (elt)))
(else (with-output-to-string
(lambda () (write elt))))))
(define (xml-tree . elts)
(map render-element elts))
(define (xml . elts)
(tree->string (apply xml-tree elts)))
(define (xml-comment . elts)
(xml-literal "\n"))
(define (xml-inline-comment . elts)
(xml-literal ""))
(define-record-type xml-literal
(make-literal s)
literal?
(s literal-string))
(define-record-printer (xml-literal L port)
(fprintf port "#" (literal-string L)))
(define (xml-literal . 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)
((not L) 0)
((string? L)
(byte-string-length L))
(else ; pair
(+ (tsl (car L))
(tsl (cdr L))))))
(tsl fragments))
;; We do not allow chars so that we don't have to know about the
;; length of a UTF8 char.
(define (tree->string tree)
(let ((buf (make-string (total-string-length tree))))
(let loop ((fragments tree) (pos 0))
(if (null? fragments)
pos
(loop (cdr fragments)
(let ((F (car fragments)))
(cond ((null? F) pos)
((not F) pos)
((pair? F) (loop F pos))
(else
(let ((len (byte-string-length F)))
(copy-bytes F buf 0 pos len)
(+ pos len))))))))
buf))
(define (for-each-fragment proc all)
(let loop ((fragments all))
(when (pair? fragments)
(let ((F (car fragments)))
(cond ((null? F))
((not F))
((pair? F) (loop F))
(else ; assume string
(proc F))))
(loop (cdr fragments)))))
;;; tests
#|
(string=?
"\n