+ feature: return-addresses; lets servlets give more than one possible
address for the next step + plain-html: leaves given text untouched, like quote in scheme don't call it quote, because it is too similar to the HTML's tag <q> (that stands for 'quote')
This commit is contained in:
parent
61896c1238
commit
20ff8816a9
|
@ -158,6 +158,9 @@
|
|||
make-image-button
|
||||
input-field-value
|
||||
input-field-binding
|
||||
|
||||
make-address
|
||||
returned-via?
|
||||
make-callback))
|
||||
|
||||
(define-structure servlets servlets-interface
|
||||
|
|
|
@ -149,12 +149,18 @@
|
|||
maybe-text
|
||||
URI)"</a>"))))
|
||||
|
||||
(define plain-html-rule
|
||||
`(plain-html
|
||||
*preorder*
|
||||
. ,(lambda (tag . text) text)))
|
||||
|
||||
(define default-rules
|
||||
`(,attribute-rule
|
||||
(*default*
|
||||
. ,(lambda (tag . elems) (apply (entag tag) elems)))
|
||||
,text-rule
|
||||
,URL-rule))
|
||||
,URL-rule
|
||||
,plain-html-rule))
|
||||
|
||||
(define (make-callback function)
|
||||
(call-with-current-continuation
|
||||
|
@ -214,11 +220,12 @@
|
|||
(input-field-name input-field))))
|
||||
|
||||
;; FIXME: consider creating small names
|
||||
(define generate-input-field-name
|
||||
(define generate-unique-name
|
||||
(let ((id 0))
|
||||
(lambda (type-string)
|
||||
(set! id (+ 1 id))
|
||||
(string-append type-string (number->string id)))))
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
(define identity (lambda (a) a))
|
||||
|
||||
|
@ -487,3 +494,29 @@
|
|||
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (cadr input-field) bindings))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; return address
|
||||
|
||||
;; generates an unique return-addres
|
||||
;; may be used like
|
||||
;; (let ((address (make-address)))
|
||||
;; (send-html/suspend
|
||||
;; (lambda (new-url)
|
||||
;; ...
|
||||
;; (URL (address new-url) "Click here to get more")...)
|
||||
(define (make-address)
|
||||
(let ((name (generate-unique-name "return")))
|
||||
(lambda (message)
|
||||
(cond
|
||||
((string? message)
|
||||
(string-append message "?" name "="))
|
||||
((eq? message 'name)
|
||||
name)
|
||||
(else ;maybe we want more later...
|
||||
(error "unknown message" message name))))))
|
||||
|
||||
|
||||
(define (returned-via? return-address bindings)
|
||||
(assoc (return-address 'name) bindings))
|
||||
|
||||
|
|
Loading…
Reference in New Issue