xhtml.ss
#lang scheme/base

(require "xml.ss"
         scheme/dict)

; technically should use the xml module to define this, buwhaever
(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"))