(module html-utils
(tabularize
itemize
enumerate
html-page
combo-box
hidden-input
text-input
password-input
submit-input)
(import chicken scheme files data-structures posix utils)
(use html-tags srfi-13 srfi-1)
(define (list-attribs attribs)
(let ((attribs
(filter-map (lambda (attrib)
(let ((value (cdr attrib)))
(and value
(list (car attrib) value))))
attribs)))
(if (null? attribs)
'()
(list (cons '@ attribs)))))
;;; tabularize
(define (sxml-tabularize data #!key table-id table-class even-row-class odd-row-class header thead/tbody)
(let ((even-row #f))
(append '(table)
(list-attribs `((id . ,table-id)
(class . ,table-class)))
(if header
(let ((h `(tr ,@(map (lambda (item) `(th ,item)) header))))
(if thead/tbody
`((thead ,h))
`(,h)))
'())
(let ((body
(map (lambda (line)
(append '(tr)
(list-attribs `((class . ,(if even-row
even-row-class
odd-row-class))))
(begin
(set! even-row (not even-row))
(map (lambda (cell) `(td ,cell)) line))))
data)))
(if thead/tbody
`((tbody ,body))
body)))))
(define (tabularize data #!key table-id table-class quote-procedure even-row-class odd-row-class header thead/tbody)
(if (generate-sxml?)
(sxml-tabularize data
table-id: table-id
table-class: table-class
even-row-class: even-row-class
odd-row-class: odd-row-class
header: header
thead/tbody: thead/tbody)
(let ((even-row #f))
(
id: table-id class: table-class quote-procedure: quote-procedure
(string-append
(if header
(let ((h ( (string-intersperse (map header) ""))))
(if thead/tbody
( h)
h))
"")
(let ((body
(string-intersperse
(map (lambda (line)
( class: (and even-row-class odd-row-class
(begin
(set! even-row (not even-row))
(if even-row
even-row-class
odd-row-class)))
(string-intersperse (map line) "")))
data)
"")))
(if thead/tbody
( | |
body)
body)))))))
;;; itemize & enumerate
(define (sxml-list listing self items #!key list-id list-class)
(cons listing
(append
(list-attribs `((id . ,list-id)
(class . ,list-class)))
(map (lambda (item)
(if (and (list? item) (eq? (car item) listing))
item
`(li ,item)))
items))))
(define (html-list listing self items #!key list-id list-class quote-procedure)
(if (generate-sxml?)
(sxml-list 'ul
itemize
items
list-id: list-id
list-class: list-class)
(listing id: list-id class: list-class quote-procedure: quote-procedure
(string-intersperse
(map (lambda (item)
(if (list? item)
(self item quote-procedure: quote-procedure)
( item)))
items)
""))))
(define (itemize items #!key list-id list-class quote-procedure)
(html-list
itemize
items
list-id: list-id
list-class: list-class
quote-procedure: quote-procedure))
(define (enumerate items #!key list-id list-class quote-procedure)
(html-list
enumerate
items
list-id: list-id
list-class: list-class
quote-procedure: quote-procedure))
;;; html-page
(define (format-sxml-attribs attribs)
(if (null? attribs)
'()
`((@ ,@attribs))))
(define (apply-tag-attribs/sxml tag attribs . content)
(cons tag (append (format-sxml-attribs attribs)
content)))
(define (sxml-page contents #!key css title doctype headers charset content-type literal-style? (html-attribs '()) (body-attribs '()))
(let ((page
(apply-tag-attribs/sxml
'html
html-attribs
(append '(head)
(if (or charset content-type)
`((meta (@ (http-equiv "Content-Type")
(content
,(string-append (or content-type
"application/xhtml+xml")
"; charset="
(or charset
"UTF-8"))))))
'())
(if title `((title ,title)) '())
(cond ((string? css)
`((link (@ (rel "stylesheet")
(href ,css)
(type "text/css")))))
((list? css)
(map (lambda (f)
(if (list? f)
(let ((data (read-all (make-pathname (current-directory) (car f)))))
`(style ,(if literal-style?
`(literal ,data)
data)))
`(link (@ (rel "stylesheet")
(href ,f)
(type "text/css")))))
css))
(else '()))
(if headers `(,headers) '()))
(if (null? contents)
(apply-tag-attribs/sxml 'body body-attribs)
(apply-tag-attribs/sxml 'body body-attribs contents)))))
(if doctype
(append `((literal ,doctype)) `(,page))
page)))
(define (apply-tag-attribs tag attribs . content)
;; Hack for html-page to accept the html-attribs/body-attribs syntax ((attrib val) ...)
(let ((kattribs (map (lambda (attrib/val)
(let ((attrib (car attrib/val))
(val (cadr attrib/val)))
(list (string->keyword (->string attrib))
val)))
attribs)))
(apply tag (append (apply append kattribs) content))))
(define (html-page contents #!key css title doctype headers charset content-type literal-style? (html-attribs '()) (body-attribs '()))
(if (generate-sxml?)
(sxml-page contents
css: css
title: title
doctype: doctype
headers: headers
charset: charset
content-type: content-type
literal-style?: literal-style?
html-attribs: html-attribs
body-attribs: body-attribs)
(string-append
(or doctype "")
(apply-tag-attribs
html-attribs
(
(if (or charset content-type)
( http-equiv: "Content-Type"
content: (string-append
(or content-type "text/html")
"; charset=" (or charset "UTF-8")))
"")
(if title ( title) "")
(cond ((string? css)
( rel: "stylesheet" href: css type: "text/css"))
((list? css)
(string-intersperse
(map (lambda (f)
(if (list? f)
(