#lang scheme/base
(require "xml.ss"
scheme/dict)
(define document-prefix "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
(define-thingy javascript
(λ (value)
(comment "/* " (cdata " */\n" value "\n/* ") " */")))
(define-named-elements
html head title style link meta
body div span
p h1 h2 h3
a object
code blockquote quote-html
form input select textarea option
ul ol li dd dt dh
table td tr th
br hr)
(define-named-elements
raw-img)
(define (keyword-sort alist)
(sort alist keyword<? #:key car))
(define not-found (list 'not-found))
(define element-defaults
(make-keyword-procedure
(λ (names values name)
(let ([defaults (map cons names values)])
(make-keyword-procedure
(λ (names values . rest)
(let ([keywords (map cons names values)])
(let ([keywords
(keyword-sort
(append (filter cdr keywords) (filter (λ (pair) (not (dict-ref keywords (car pair) (λ () #f)))) defaults)))])
(keyword-apply element (map car keywords) (map cdr keywords) (cons name rest))))))))))
(define img (element-defaults 'img #:alt "unknown"))
(define (script source)
(element 'script #:type "text/javascript" (javascript source)))
(define document
(make-keyword-procedure
(λ (names values header . contents)
(join document-prefix
(html
#:xmlns "http://www.w3.org/1999/xhtml"
#:xml:lang "en"
#:lang "en"
header
(keyword-apply body names values contents))))))
(define (build-head title-s #:style [style #f] . rest)
(head (title title-s)
(if style (link #:rel "stylesheet" #:type "text/css" #:href style) #f)
(meta #:http-equiv "content-type" #:content "application/xhtml+xml; charset=UTF-8")
rest))
(define tag element)
(provide (all-defined-out) (all-from-out "xml.ss"))![[logo]](/logo.png){kind=logo}