+ major change in internal representation of forms and its elements

+ SERVLET-FORM now introduces a special form with our input-fields
+ servlet-forms may be nested
This commit is contained in:
interp 2002-09-27 15:24:44 +00:00
parent 9c6db22736
commit 99fb8f3e32
1 changed files with 134 additions and 80 deletions

View File

@ -89,39 +89,67 @@
;; adapted from Oleg's SXML-to-HTML.scm
;; extended by additional port argument
(define (servlet-XML->HTML out html-tree)
(formated-reply out
(pre-post-order html-tree
;; Universal transformation rules. Work for every HTML,
;; present and future
`(,@default-rules
(form *preorder* .
,(lambda (trigger call-back-function . elems)
(list "<form method=\"GET\" action=\"" call-back-function
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
(list (car elems) "\">\n" (parse-form-elems (cdr elems)) "</form>")
(list "\">\n" (parse-form-elems elems) "</form>"))))))
)))
(formated-reply out
(reformat html-tree)))
(define (parse-form-elems elems)
(map (lambda (elem)
(if (input-field? elem)
(post-order (input-field-HTML-tree elem) default-rules)
(post-order elem default-rules)))
elems))
(define (reformat html-tree)
(pre-post-order
html-tree
`(
;; Universal transformation rules. Works for every HTML,
;; present and future
,@default-rules
(input-field
*preorder*
. ,(lambda (trigger input-field)
(reformat (input-field-HTML-tree input-field))))
(servlet-form
;; Must do something to prevent the callback-function string to
;; be HTML escaped.
*preorder*
. ,(lambda (trigger call-back-function . elems)
(if (and (pair? elems)
(XML-attribute? (car elems)))
(make-servlet-form call-back-function (cdar elems) (cdr elems))
(make-servlet-form call-back-function'() elems)))))
))
(define (make-servlet-form call-back-function attributes elems)
`("<form" ,@(map (lambda (attribute-value)
((enattr (car attribute-value)) (cadr attribute-value)))
`((method "GET")
(action ,call-back-function)
,@attributes))
#\> #\newline
,(reformat elems)
"</form>"))
(define (XML-attribute? thing)
(and (pair? thing)
(eq? '@ (car thing))))
(define attribute-rule
`(@ ; local override for attributes
((*default*
. ,(lambda (attr-key . value) ((enattr attr-key) value))))
. ,(lambda (trigger . value) (list '@ value))))
(define text-rule
`(*text*
. ,(lambda (trigger str)
(if (string? str) (string->goodHTML str) str))))
(define URL-rule
(cons 'URL
(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
(define text-html-rule
`(*text* . ,(lambda (trigger str)
(if (string? str) (string->goodHTML str) str))))
(define default-rules
`((@ ; local override for attributes
((*default*
. ,(lambda (attr-key . value) ((enattr attr-key) value))))
. ,(lambda (trigger . value) (list '@ value)))
(*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
,text-html-rule
(URL . ,(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
)
`(,attribute-rule
(*default*
. ,(lambda (tag . elems) (apply (entag tag) elems)))
,text-rule
,URL-rule))
(define (make-callback function)
(call-with-current-continuation
@ -131,8 +159,20 @@
(bindings (form-query (http-url:search (request:url req)))))
(function bindings)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for servlets
(define-record-type input-field :input-field
(make-input-field name transformer HTML-tree)
(real-make-input-field name transformer HTML-tree)
input-field?
(name input-field-name)
(transformer input-field-transformer)
@ -152,6 +192,9 @@
(define identity (lambda (a) a))
(define (make-input-field name transformer HTML-tree)
(list 'input-field (real-make-input-field name transformer HTML-tree)))
(define (make-text-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "text")))
(make-input-field name
@ -162,21 +205,23 @@
(define (make-number-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "number")))
(make-input-field name
(lambda (string)
(or (string->number string)
(error "wrong type")))
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(make-input-field
name
(lambda (string)
(or (string->number string)
(error "wrong type")))
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password")))
(make-input-field name
identity
`(input (@ (type "password")
(name ,name)
,@maybe-further-attributes)))))
(make-input-field
name
identity
`(input (@ (type "password")
(name ,name)
,@maybe-further-attributes)))))
(define (make-textarea-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea"))
@ -184,44 +229,47 @@
(string? (car maybe-further-attributes)))
(car maybe-further-attributes)
'())))
(make-input-field name
identity
`(textarea (@ (type "textarea")
(name ,name)
,@maybe-further-attributes)
,default-text))))
(make-input-field
name
identity
`(textarea (@ (type "textarea")
(name ,name)
,@maybe-further-attributes)
,default-text))))
(define (make-select-input-field options . maybe-further-attributes)
(let ((name (generate-input-field-name "select")))
(make-input-field name
(lambda (select)
select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,@maybe-further-attributes))
#\newline
,@(map (lambda (option)
(if (pair? option) ; with attributes?
`(option (@ ,@(cdr option)) ,(car option))
`(option ,option)))
options)))))
(make-input-field
name
(lambda (select)
select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,@maybe-further-attributes))
#\newline
,@(map (lambda (option)
(if (pair? option) ; with attributes?
`(option (@ ,@(cdr option)) ,(car option))
`(option ,option)))
options)))))
;; in work
(define (make-radio-input-field values . maybe-further-attributes)
(let ((name (generate-input-field-name "radio")))
(make-input-field name
(lambda (select)
select) ;FIXME refer to list elements
(map (lambda (value)
`((input (@ ((type "radio")
(name ,name)
,@maybe-further-attributes
,(if (pair? value) ; with attributes?
(cdr value)
'())))) ;FIXME: add value field
,(if (pair? value) ; with attributes?
(car value)
value)))
values))))
(make-input-field
name
(lambda (select)
select) ;FIXME refer to list elements
(map (lambda (value)
`((input (@ ((type "radio")
(name ,name)
,@maybe-further-attributes
,(if (pair? value) ; with attributes?
(cdr value)
'())))) ;FIXME: add value field
,(if (pair? value) ; with attributes?
(car value)
value)))
values))))
@ -238,14 +286,18 @@
,@maybe-further-attributes))))
(define (input-field-value input-field bindings)
(cond
((assoc (input-field-name input-field) bindings) =>
(lambda (binding)
((input-field-transformer input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings))))
(let ((input-field (cadr input-field)))
(cond
((assoc (input-field-name input-field) bindings) =>
(lambda (binding)
((input-field-transformer input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings)))))
;;; tests
(define number-input-field (make-number-input-field))
(define test
@ -256,3 +308,5 @@
(p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
,(make-submit-button))))))