;; string -> string -> [string]
(define ?xml
  (lambda (version encoding)
    (list "<?xml version=\"" version "\" encoding=\"" encoding "\"?>\n")))

;; string -> string -> string -> string -> [string]
(define !doctype
  (lambda (nm dm ds fn)
    (list "<!DOCTYPE " nm " " dm " \"" ds "\"\n \"" fn "\">\n")))

;; type attr = [string, string]

;; string -> (string -> attr)
(define mk-attr
  (lambda (name)
    (lambda (value)
      (list name value))))

(define xmlns (mk-attr "xmlns"))
(define xml:lang (mk-attr "xml:lang"))
(define lang (mk-attr "lang"))
(define name (mk-attr "name"))
(define content (mk-attr "content"))
(define rel (mk-attr "rel"))
(define href (mk-attr "href"))
(define type (mk-attr "type"))
(define data (mk-attr "data"))
(define class (mk-attr "class"))
(define src (mk-attr "src"))
(define width (mk-attr "width"))
(define height (mk-attr "height"))
(define alt (mk-attr "alt"))
(define title (mk-attr "title"))
(define id (mk-attr "id"))
(define http-equiv (mk-attr "http-equiv"))
(define border (mk-attr "border"))
(define colspan (mk-attr "colspan"))
(define rowspan (mk-attr "rowspan"))
(define align (mk-attr "align"))
(define valign (mk-attr "valign"))

;; attr ... -> [attr]
(define attr list)

;; []
(define noattr
  (attr))

;; string -> [attr]
(define w/class
  (lambda (c)
    (attr (class c))))

;; string -> [attr]
(define w/class+id
  (lambda (c)
    (attr (class c) (id c))))

;; [attr] -> [string] -> tree string
(define build-attr
  (lambda (a attr)
    (if (all (lambda (i) (elem i attr)) (map car a))
	(zip-with
         (lambda (key value) (list " " key "=\"" value "\""))
         (map car a)
         (map cadr a))
	(error "illegal attribute:" a " not in " attr))))

;; string -> bool -> bool -> [string] -> ([attr] -> elem ... -> tree string)
(define sgml-element
  (lambda (elem inline? content? allowable)
    (let ((n (if inline? "" "\n")))
      (if content?
	  (lambda (a . c)
	    (list "<" elem (build-attr a allowable) ">" n c n "</" elem ">" n))
	  (lambda (a)
	    (list "<" elem (build-attr a allowable) " />" n))))))

(define html (sgml-element "html" #f #t (list "xmlns" "xml:lang" "lang")))
(define head (sgml-element "head" #f #t (list)))
(define title* (sgml-element "title" #f #t (list "class")))
(define meta (sgml-element "meta" #f #f (list "name" "content" "http-equiv")))
(define link (sgml-element "link" #f #f (list "rel" "href" "name" "type")))
(define body (sgml-element "body" #f #t (list "class")))
(define div (sgml-element "div" #f #t (list "class")))
(define span (sgml-element "span" #t #t (list "class")))
(define h1 (sgml-element "h1" #f #t (list "class" "title")))
(define h2 (sgml-element "h2" #f #t (list "class" "title")))
(define h3 (sgml-element "h3" #f #t (list "class" "title")))
(define p (sgml-element "p" #f #t (list "class" "id")))
(define dl (sgml-element "dl" #f #t (list "class")))
(define dt (sgml-element "dt" #f #t (list "class")))
(define dd (sgml-element "dd" #f #t (list "class")))
(define ol (sgml-element "ol" #f #t (list "class" "id")))
(define ul (sgml-element "ul" #f #t (list "class" "id")))
(define li (sgml-element "li" #f #t (list "class")))
(define a (sgml-element "a" #t #t (list "class" "href" "name" "title")))
(define img (sgml-element "img" #t #f (list "class" "src" "alt" "width" "height")))
(define em (sgml-element "em" #t #t (list "class")))
(define br (sgml-element "br" #f #f (list "class")))
(define table (sgml-element "table" #f #t (list "class" "border")))
(define tr (sgml-element "tr" #f #t (list "class")))
(define td (sgml-element "td" #f #t (list "class" "colspan" "rowspan" "width" "height" "align" "valign")))
(define th (sgml-element "th" #f #t (list "class")))
(define colgroup (sgml-element "colgroup" #f #t (list "class" "span" "width" "align" "valign")))
(define acronym (sgml-element "acronym" #t #t (list "class" "title")))
(define address (sgml-element "address" #f #t (list "class" "title")))
(define small (sgml-element "small" #t #t (list "class")))
(define strong (sgml-element "strong" #t #t (list "class")))
(define object (sgml-element "object" #t #t (list "type" "name" "data")))

;; (string -> attr) -> string -> string -> element
(define make-meta
  (lambda (type n c)
    (meta (attr (type n) (content c)))))

;; string -> string -> string -> element
(define make-link
  (lambda (r h t)
    (link (attr (rel r) (href h) (type t)))))

;; string
(define xhtml-validator
  "http://validator.w3.org/check/referer")

;; string
(define css-validator
  "http://jigsaw.w3.org/css-validator/check/referer")

;; char -> tree char
(define encode-char
  (lambda (c)
    (case c
      ((#\&) (string->list "&amp;"))
      ((#\<) (string->list "&lt;"))
      ((#\>) (string->list "&gt;"))
      ((#\") (string->list "&quot;"))
      (else c))))

;; string -> string
(define encode-string
  (lambda (s)
    (list->string
     (flatten
      (map
       encode-char
       (string->list s))))))