source: project/release/4/html-form/trunk/html-form.scm @ 14413

Last change on this file since 14413 was 14413, checked in by Ivan Raikov, 12 years ago

html-form ported to Chicken 4

File size: 5.2 KB
Line 
1;;
2;;
3;; Directed graph in adjacency list format.
4;; Based on code from MLRISC
5;;
6;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
7;;
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21
22(module html-form
23
24 (html-form)
25                   
26 (import scheme chicken )
27
28 (require-extension srfi-1 srfi-13 )
29
30(define nl (list->string (list #\newline)))
31
32(define lookup-field 
33  (lambda (k lst . rest)
34    (let-optionals rest ((default #f))
35      (let loop ((lst lst))
36        (if (null? lst) default
37            (let ((elm (car lst)))
38              (match elm
39                     ((s . _)  (if (eq? s k) (cdr elm)  (loop (cdr lst))))
40                     (else  (loop (cdr lst))))))))))
41
42(define (single x) (and x (or (and (list? x) (car x)) x)))
43
44(define (s+ . rest) 
45  (apply string-append (map ->string rest)))
46
47(define special-attrs 
48  `(label rel optional hint label-class hint-class field-class))
49
50(define (special-attr? x) (member x special-attrs))
51
52(define (pid parent id)
53  (if parent (s+ parent "_" id) (->string id)))
54
55(define (html-form x)
56  (and (list? x)
57       (case (car x)
58         ((form-group)  (group (cadr x) (cddr x)))
59         (else          (apply field x)))))
60
61(define (group group-name rest)
62  (let ((children   (lookup-field 'children rest))
63        (label      (lookup-field 'label rest)))
64    `(div (@ (id ,group-name))
65          (fieldset (@ (class repeat) )
66                    (legend ,(or label group-name))
67                    ,(map (lambda (x) (list (html-form x) nl)) (or children (list)))))))
68
69(define (field name default . rest)
70  (let ((hint        (lookup-field 'hint rest))
71        (label       (or (lookup-field 'label rest) name))
72        (rel         (lookup-field 'rel rest))
73        (optional    (lookup-field 'optional rest))
74        (field-class (or (lookup-field 'field-class rest) 'oneField))
75        (label-class (or (lookup-field 'label-class rest) 'preField))
76        (hint-class  (or (lookup-field 'hint-class rest) 'inlineLabel)))
77  `(div (@ ,(if optional  `(rel ,optional)  `()))
78        (span (@ (class ,field-class))
79              (label (@ (for ,name) (class ,label-class)) ,label)
80              ,(if hint `(p (@ (class ,hint-class)) ,hint)  `())
81              ,(widget name label rel default (filter (lambda (x) (not (special-attr? (car x)))) rest))))))
82
83(define (widget name label rel value rest)
84  (or (and (pair? rest)
85           (let ((prop (car rest)))
86             (case (car prop)
87               ((checkbox)   (checkbox name label rel value))
88               ((textarea)   (apply textarea (cons* name label rel value (cdr prop))))
89               ((select)     (apply selection (cons* name label rel (cdr prop))))
90               ((button)     (apply button (cons* name label rel value (cdr prop))))
91               ((radio)      (apply radio (cons* name label rel value (cdr prop))))
92               (else         #f))))
93      (text name label rel value)))
94
95(define (checkbox name label rel value . rest)
96  `(input (@ (type checkbox) (name ,name) (id ,name) (title ,label) (value ,value)
97             ,(if rel `(rel ,rel) `()))))
98
99(define (textarea name label rel value . rest)
100  (let ((rows (single (lookup-field 'rows rest)))
101        (cols (single (lookup-field 'cols rest)))
102        (value (if (list? value) value (list value))))
103    (if (not (and rows cols)) (error 'textarea "missing rows and cols attributes"))
104    `((textarea (@ (name ,name) (id ,name) (rows ,rows) (cols ,cols) (title ,label)
105        ,(if rel `(rel ,rel) `())) ,nl
106        ,(let ((irows (if (string? rows) (string->number rows) rows))
107               (icols (if (string? cols) (string->number cols) cols)))
108           (let rloop ((i irows) (lst value) (ax (list)))
109             (let cloop ((j icols) (lst lst) (ax ax))
110               (if (null? lst) (reverse ax)
111                   (if (> j 0) (cloop (- j 1) (cdr lst) (cons " " (cons (car lst) ax)))
112                       (if (> i 1) (rloop (- i 1) lst (cons nl ax)) 
113                           (reverse (cons nl ax)))))))))
114      (p))))
115
116
117(define (selection name label rel value . rest)
118  `(select (@ (name ,name) (id ,name) (title ,label) ,(if rel `(rel ,rel) `()))
119           ,(map (lambda (x) `((option (@ (value ,x) (label ,x)) ,x) ,nl)) value)))
120
121(define (button name label rel value . rest)
122  (let ((onclick  (lookup-field 'onclick rest)))
123    `(input (@ (type button) (name ,name) (id ,name) (value ,value) (title ,label) 
124               ,(if rel `(rel ,rel) `()) 
125               ,(if onclick `(script (onclick  ,onclick)) `())))))
126
127(define (radio name label rel value . rest)
128  (map (lambda (x) 
129         (let-values (((rname ropts) 
130                       (match x ((name . opts)  (values (->string name) opts))
131                              (else  (values (->string x) (list))))))
132                     (let ((rel (lookup-field 'rel ropts)))
133                       `( ,rname ": "
134                                 (input (@ (type radio) (name ,name) (id ,(pid name rname))
135                                           (value ,rname) (title ,rname) 
136                                           ,(if rel `(rel ,rel) `())))))))
137       rest))
138
139(define (text name label rel value . rest)
140  `(input (@ (name ,name) (id ,name) (title ,label) (value ,value)
141             ,(if (string? value) `(type "text") `())
142             ,(if rel `(rel ,rel) `()))))
143
144)
Note: See TracBrowser for help on using the repository browser.