PLaneT Package Repository : Home > synx > xml-maker.plt

Home > synx > xml-maker.plt > package version 1.0
xhtml.ss
#lang scheme

(require "xml.ss")

; technically should use the xml module to define this, buwhaever
(define 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-named-elements
  html head title style link meta 
  body div span
  p h1 h2 h3 
  a object
  code blockquote quote-html
  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 (document head-contents . contents)
  (join prefix
        (html 
         #:xmlns "http://www.w3.org/1999/xhtml" 
         #:xml:lang "en" 
         #:lang "en"
         (head head-contents)
         (body contents))))

(define (build-head title-s #:style [style #f] . rest)
  (list (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"))