+ 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
parent
9c6db22736
commit
99fb8f3e32
|
|
@ -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 (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))))
|
||||
|
||||
(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))
|
||||
(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))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue