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

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

html-utils: the doctype thing was actually right

File size: 11.8 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 (html-page contents #!key css title doctype headers charset)
166  (if (generate-sxml?)
167      (sxml-page contents
168                 css: css
169                 title: title
170                 doctype: doctype
171                 headers: headers
172                 charset: charset)
173      (string-append
174       (or doctype "")
175       (<html>
176        (<head>
177         (if charset
178             (<meta> http-equiv: "Content-Type"
179                     content:  (string-append "text/html; charset=" charset))
180             "")
181         (if title (<title> title) "")
182         (cond ((string? css)
183                (<link> rel: "stylesheet" href: css type: "text/css"))
184               ((list? css)
185                (string-intersperse
186                 (map (lambda (f)
187                        (if (list? f)
188                            (<style> (read-all (make-pathname (current-directory) (car f))))
189                            (<link> rel: "stylesheet" href: f type: "text/css")))
190                      css)
191                 ""))
192               (else ""))
193         (or headers ""))
194        (if (string-prefix-ci? "<body" contents)
195            contents
196            (<body> contents))))))
197
198
199;;; combo-box
200(define (sxml-make-options options #!optional default first-empty)
201  (let ((opts (map (lambda (opt)
202                     (let ((val (->string (cond ((pair? opt) (car opt))
203                                                ((vector? opt) (vector-ref opt 0))
204                                                (else opt))))
205                           (text (->string (cond ((list? opt) (cadr opt))
206                                                 ((pair? opt) (cdr opt))
207                                                 ((vector? opt) (vector-ref opt 1))
208                                                 (else opt)))))
209                       (<option> value: val
210                                 selected: (and default (equal? val (->string default)))
211                                 text)))
212                   options)))
213    (if first-empty
214        (cons (<option> selected: (and default (equal? "" (->string default))))
215              opts)
216        opts)))
217
218(define (make-options options #!optional default first-empty)
219  (if (generate-sxml?)
220      (sxml-make-options options default first-empty)
221      (string-append
222       (if first-empty
223           (<option> selected: (and default (equal? "" (->string default))))
224           "")
225       (string-intersperse
226        (map (lambda (opt)
227               (let ((val (->string (cond ((pair? opt) (car opt))
228                                          ((vector? opt) (vector-ref opt 0))
229                                          (else opt))))
230                     (text (->string (cond ((list? opt) (cadr opt))
231                                           ((pair? opt) (cdr opt))
232                                           ((vector? opt) (vector-ref opt 1))
233                                           (else opt)))))
234                 (<option> value: val
235                           selected: (and default (equal? val (->string default)))
236                           text)))
237             options)
238        ""))))
239
240(define (combo-box name options #!key default id first-empty onchange onkeyup disabled
241                   length multiple selectedindex size tabindex type class)
242  (if (generate-sxml?)
243      (append '(select)
244              (list-attribs `((name . ,name)
245                              (id . ,(or id name))
246                              (onchange . ,onchange)
247                              (onkeyup . ,onkeyup)
248                              (disabled . ,disabled)
249                              (length . ,length)
250                              (multiple . ,multiple)
251                              (selectedindex . ,selectedindex)
252                              (size . ,size)
253                              (tabindex . ,tabindex)
254                              (type . ,type)
255                              (class . ,class)))
256              (sxml-make-options options default first-empty))
257  (<select> onchange: onchange
258            onkeyup: onkeyup
259            disabled: disabled
260            length: length
261            multiple: multiple
262            selectedindex: selectedindex
263            size: size
264            tabindex: tabindex
265            type: type
266            name: name
267            id: (or id name)
268            class: class
269            (make-options options default first-empty))))
270
271
272;;; inputs
273(define (sxml-hidden-input name #!optional value id)
274  (if (list? name)
275      (map (lambda (item)
276             (let ((name (->string (car item))))
277               (<input> type: "hidden"
278                        id: (or id name)
279                        name: name
280                        value: (->string (cdr item)))))
281           name)
282      (<input> type: "hidden" name: name id: (or id name) value: value)))
283
284(define (hidden-input name #!optional value id)
285  (if (generate-sxml?)
286      (sxml-hidden-input name value id)
287      (if (list? name)
288          (string-intersperse
289           (map (lambda (item)
290                  (let ((name (->string (car item))))
291                    (<input> type: "hidden"
292                             id: (or id name)
293                             name: name
294                             value: (->string (cdr item)))))
295                name)
296           "")
297          (<input> type: "hidden" name: name id: (or id name) value: value))))
298
299(define (text-input name . args)
300  (apply <input>
301         (append
302          (list type: "text"
303                name: name
304                id: (or (get-keyword id: args) name))
305          args)))
306
307(define (password-input name . args)
308  (apply <input>
309         (append
310          (list type: "password"
311                name: name
312                id: (or (get-keyword id: args) name))
313          args)))
314
315(define (submit-input . args)
316  (apply <input> type: "submit" args))
317
318) ;; end module
Note: See TracBrowser for help on using the repository browser.