source: project/release/4/html-utils/trunk/html-utils.scm @ 27167

Last change on this file since 27167 was 27167, checked in by Mario Domenech Goulart, 9 years ago

html-utils: html-page: respect user-provided doctype in SXML mode

File size: 12.0 KB
Line 
1(module html-utils
2  (tabularize
3   itemize
4   enumerate
5   html-page
6   combo-box
7   hidden-input
8   text-input
9   password-input
10   submit-input)
11
12(import chicken scheme files data-structures posix utils)
13(use html-tags srfi-13 srfi-1)
14
15(define (list-attribs attribs)
16  (let ((attribs
17         (filter-map (lambda (attrib)
18                       (let ((value (cdr attrib)))
19                         (and value
20                              (list (car attrib) value))))
21                     attribs)))
22    (if (null? attribs)
23        '()
24        (list (cons '@ attribs)))))
25
26
27;;; tabularize
28(define (sxml-tabularize data #!key table-id table-class even-row-class odd-row-class header thead/tbody)
29  (let ((even-row #f))
30    (append '(table)
31            (list-attribs `((id . ,table-id)
32                            (class . ,table-class)))
33            (if header
34                (let ((h `(tr ,@(map (lambda (item) `(th ,item)) header))))
35                  (if thead/tbody
36                      `((thead ,h))
37                      `(,h)))
38                '())
39            (let ((body
40                   (map (lambda (line)
41                          (append '(tr)
42                                  (list-attribs `((class . ,(if even-row
43                                                                even-row-class
44                                                                odd-row-class))))
45                                  (begin
46                                    (set! even-row (not even-row))
47                                    (map (lambda (cell) `(td ,cell)) line))))
48                        data)))
49              (if thead/tbody
50                  `((tbody ,body))
51                  body)))))
52
53
54(define (tabularize data #!key table-id table-class quote-procedure even-row-class odd-row-class header thead/tbody)
55  (if (generate-sxml?)
56      (sxml-tabularize data
57                       table-id: table-id
58                       table-class: table-class
59                       even-row-class: even-row-class
60                       odd-row-class: odd-row-class
61                       header: header
62                       thead/tbody: thead/tbody)
63      (let ((even-row #f))
64        (<table> id: table-id class: table-class quote-procedure: quote-procedure
65                 (string-append
66                  (if header
67                      (let ((h (<tr> (string-intersperse (map <th> header) ""))))
68                        (if thead/tbody
69                            (<thead> h)
70                            h))
71                      "")
72                  (let ((body
73                         (string-intersperse
74                          (map (lambda (line)
75                                 (<tr> class: (and even-row-class odd-row-class
76                                                   (begin
77                                                     (set! even-row (not even-row))
78                                                     (if even-row
79                                                         even-row-class
80                                                         odd-row-class)))
81                                       (string-intersperse (map <td> line) "")))
82                               data)
83                          "")))
84                    (if thead/tbody
85                        (<tbody> body)
86                        body)))))))
87
88
89;;; itemize & enumerate
90(define (sxml-list listing self items #!key list-id list-class)
91  (cons listing
92        (append
93         (list-attribs `((id . ,list-id)
94                         (class . ,list-class)))
95         (map (lambda (item)
96                (if (and (list? item) (eq? (car item) listing))
97                    item
98                    `(li ,item)))
99              items))))
100
101(define (html-list listing self items #!key list-id list-class quote-procedure)
102  (if (generate-sxml?)
103      (sxml-list 'ul
104                 itemize
105                 items
106                 list-id: list-id
107                 list-class: list-class)
108      (listing id: list-id class: list-class quote-procedure: quote-procedure
109               (string-intersperse
110                (map (lambda (item)
111                       (if (list? item)
112                           (self item quote-procedure: quote-procedure)
113                           (<li> item)))
114                     items)
115                ""))))
116
117(define (itemize items #!key list-id list-class quote-procedure)
118  (html-list <ul>
119             itemize
120             items
121             list-id: list-id
122             list-class: list-class
123             quote-procedure: quote-procedure))
124
125(define (enumerate items #!key list-id list-class quote-procedure)
126  (html-list <ol>
127             enumerate
128             items
129             list-id: list-id
130             list-class: list-class
131             quote-procedure: quote-procedure))
132
133
134;;; html-page
135(define (sxml-page contents #!key css title doctype headers charset)
136  (let ((page
137         `(html
138           ,(append '(head)
139                    (if charset
140                        `((meta (@ (http-equiv "Content-Type")
141                                   (content ,(string-append "text/html; charset=" charset)))))
142                        '())
143                    (if title `((title ,title)) '())
144                    (cond ((string? css)
145                           `((link (@ (rel "stylesheet")
146                                      (href ,css)
147                                      (type "text/css")))))
148                          ((list? css)
149                           (map (lambda (f)
150                                  (if (list? f)
151                                      `(style ,(read-all (make-pathname (current-directory) (car f))))
152                                      `(link (@ (rel "stylesheet")
153                                                (href ,f)
154                                                (type "text/css")))))
155                                css))
156                          (else '()))
157                    (if headers `(,headers) '()))
158           ,(if (string? contents)
159                `(body ,contents)
160                `(body ,@contents)))))
161    (if doctype
162        (append `((literal ,doctype)) `(,page))
163        page)))
164
165(define sxml-doctype
166  "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
167
168(define (html-page contents #!key css title doctype headers charset)
169  (if (generate-sxml?)
170      (sxml-page contents
171                 css: css
172                 title: title
173                 doctype: (or doctype sxml-doctype)
174                 headers: headers
175                 charset: charset)
176      (string-append
177       (or doctype "")
178       (<html>
179        (<head>
180         (if charset
181             (<meta> http-equiv: "Content-Type"
182                     content:  (string-append "text/html; charset=" charset))
183             "")
184         (if title (<title> title) "")
185         (cond ((string? css)
186                (<link> rel: "stylesheet" href: css type: "text/css"))
187               ((list? css)
188                (string-intersperse
189                 (map (lambda (f)
190                        (if (list? f)
191                            (<style> (read-all (make-pathname (current-directory) (car f))))
192                            (<link> rel: "stylesheet" href: f type: "text/css")))
193                      css)
194                 ""))
195               (else ""))
196         (or headers ""))
197        (if (string-prefix-ci? "<body" contents)
198            contents
199            (<body> contents))))))
200
201
202;;; combo-box
203(define (sxml-make-options options #!optional default first-empty)
204  (let ((opts (map (lambda (opt)
205                     (let ((val (->string (cond ((pair? opt) (car opt))
206                                                ((vector? opt) (vector-ref opt 0))
207                                                (else opt))))
208                           (text (->string (cond ((list? opt) (cadr opt))
209                                                 ((pair? opt) (cdr opt))
210                                                 ((vector? opt) (vector-ref opt 1))
211                                                 (else opt)))))
212                       (<option> value: val
213                                 selected: (and default (equal? val (->string default)))
214                                 text)))
215                   options)))
216    (if first-empty
217        (cons (<option> selected: (and default (equal? "" (->string default))))
218              opts)
219        opts)))
220
221(define (make-options options #!optional default first-empty)
222  (if (generate-sxml?)
223      (sxml-make-options options default first-empty)
224      (string-append
225       (if first-empty
226           (<option> selected: (and default (equal? "" (->string default))))
227           "")
228       (string-intersperse
229        (map (lambda (opt)
230               (let ((val (->string (cond ((pair? opt) (car opt))
231                                          ((vector? opt) (vector-ref opt 0))
232                                          (else opt))))
233                     (text (->string (cond ((list? opt) (cadr opt))
234                                           ((pair? opt) (cdr opt))
235                                           ((vector? opt) (vector-ref opt 1))
236                                           (else opt)))))
237                 (<option> value: val
238                           selected: (and default (equal? val (->string default)))
239                           text)))
240             options)
241        ""))))
242
243(define (combo-box name options #!key default id first-empty onchange onkeyup disabled
244                   length multiple selectedindex size tabindex type class)
245  (if (generate-sxml?)
246      (append '(select)
247              (list-attribs `((name . ,name)
248                              (id . ,(or id name))
249                              (onchange . ,onchange)
250                              (onkeyup . ,onkeyup)
251                              (disabled . ,disabled)
252                              (length . ,length)
253                              (multiple . ,multiple)
254                              (selectedindex . ,selectedindex)
255                              (size . ,size)
256                              (tabindex . ,tabindex)
257                              (type . ,type)
258                              (class . ,class)))
259              (sxml-make-options options default first-empty))
260  (<select> onchange: onchange
261            onkeyup: onkeyup
262            disabled: disabled
263            length: length
264            multiple: multiple
265            selectedindex: selectedindex
266            size: size
267            tabindex: tabindex
268            type: type
269            name: name
270            id: (or id name)
271            class: class
272            (make-options options default first-empty))))
273
274
275;;; inputs
276(define (sxml-hidden-input name #!optional value id)
277  (if (list? name)
278      (map (lambda (item)
279             (let ((name (->string (car item))))
280               (<input> type: "hidden"
281                        id: (or id name)
282                        name: name
283                        value: (->string (cdr item)))))
284           name)
285      (<input> type: "hidden" name: name id: (or id name) value: value)))
286
287(define (hidden-input name #!optional value id)
288  (if (generate-sxml?)
289      (sxml-hidden-input name value id)
290      (if (list? name)
291          (string-intersperse
292           (map (lambda (item)
293                  (let ((name (->string (car item))))
294                    (<input> type: "hidden"
295                             id: (or id name)
296                             name: name
297                             value: (->string (cdr item)))))
298                name)
299           "")
300          (<input> type: "hidden" name: name id: (or id name) value: value))))
301
302(define (text-input name . args)
303  (apply <input>
304         (append
305          (list type: "text"
306                name: name
307                id: (or (get-keyword id: args) name))
308          args)))
309
310(define (password-input name . args)
311  (apply <input>
312         (append
313          (list type: "password"
314                name: name
315                id: (or (get-keyword id: args) name))
316          args)))
317
318(define (submit-input . args)
319  (apply <input> type: "submit" args))
320
321) ;; end module
Note: See TracBrowser for help on using the repository browser.