+ export conversion rules from surflets:

default-rules (default, text, attribute, plain-html and url)
  surflet-form-rules (input-field and surflet-form)
+ according to mainzelm: lowercase URL tag to url in surflet-xml
This commit is contained in:
interp 2003-03-09 20:15:08 +00:00
parent 31f0044e2c
commit 3b51f7b82b
13 changed files with 109 additions and 76 deletions

View File

@ -120,7 +120,12 @@
my-session-id
my-continuation-id
my-ids)))
my-ids
surflet-form-rules
default-rules
url-rule
plain-html-rule)))
;; THE interface that SUrflets use.
(define-interface surflet-interface

View File

@ -66,7 +66,7 @@
(br)
(p ,@text)
(br)
(URL ,url "Continue"))))))
(url ,url "Continue"))))))
;; Post some information on a Web page, shut down the surflet and all
;; its continuations.

View File

@ -165,11 +165,15 @@
(define (reformat html-tree)
(pre-post-order
html-tree
`(
;; Universal transformation rules. Works for every HTML,
;; present and future
,@default-rules
(,input-field-trigger
`(,@default-rules
;; form contents:
,@surflet-form-rules)))
;; Used in input-fields as well
(define *input-field-trigger* '*input-field*)
(define surflet-form-rules
`((,*input-field-trigger*
*preorder*
. ,(lambda (trigger input-field)
(reformat (input-field-html-tree input-field))))
@ -184,8 +188,7 @@
(make-surflet-form k-url ; k-url
(car parameters) ; POST, GET or #f=GET
(cadr parameters); attributes
elems))))) ; form-content
))
elems))))))
(define (make-surflet-form k-url method attributes elems)
(let ((real-method (case method
@ -223,11 +226,11 @@
(if (string? str) (string->goodHTML str) str))))
(define url-rule
(cons 'URL
(lambda (tag URI . maybe-text)
(list "<a href=\"" URI "\">"
(cons 'url
(lambda (tag uri . maybe-text)
(list "<a href=\"" uri "\">"
(if (null? maybe-text)
URI
uri
maybe-text)
"</a>"))))
@ -279,7 +282,7 @@
(p "The page or action you requested relies on outdated data.")
,(if url
`(p "Try to "
(URL ,url "reload")
(url ,url "reload")
" the page to get current data.")
'())))))
@ -304,12 +307,11 @@
(input-field-name input-field))))
;; Have to do a trick to get around with SSAX: input-field is a list
;; whose first element is input-field-trigger and the last (next) one
;; whose first element is *input-field-trigger* and the last (next) one
;; is a real input-field.
(define input-field-trigger '*input-field*)
(define (input-field? input-field)
(and (pair? input-field)
(eq? input-field-trigger (car input-field))
(eq? *input-field-trigger* (car input-field))
(real-input-field? (cadr input-field))))
;; FIXME: consider creating small names
@ -324,10 +326,12 @@
;; See note at input-field? for reasons for the list.
(define (make-input-field name transformer html-tree)
(list input-field-trigger (real-make-input-field name transformer html-tree #f)))
(list *input-field-trigger*
(real-make-input-field name transformer html-tree #f)))
(define (make-higher-input-field transformer html-tree)
(list input-field-trigger (real-make-input-field #f transformer html-tree #t)))
(list *input-field-trigger*
(real-make-input-field #f transformer html-tree #t)))
;; PRED-LIST contains list of predicates that recognizes optional
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
@ -637,7 +641,7 @@
;; (send-html/suspend
;; (lambda (new-url)
;; ...
;; (URL (address new-url) "Click here to get more")...)
;; (url (address new-url) "Click here to get more")...)
(define-record-type address :address
(really-make-address name annotated?)

View File

@ -23,8 +23,8 @@
(name "number"))
(input (@ (type "submit"))))))
(hr)
(p (URL "/" "Return to main menu") (br)
(URL "add-html.scm" "Start new calculation."))))))))
(p (url "/" "Return to main menu") (br)
(url "add-html.scm" "Start new calculation."))))))))
(let* ((bindings (form-query-list
(http-url-search (surflet-request-url result))))
(number (string->number

View File

@ -16,8 +16,8 @@
,number-input-field
,(make-submit-button)))
(hr)
(p (URL "/" "Return to main menu.") (br)
(URL "add-surflet.scm" "Start new calculation."))))))
(p (url "/" "Return to main menu.") (br)
(url "add-surflet.scm" "Start new calculation."))))))
(define (get-number title input-text)
(let* ((result (send-html/suspend
@ -40,10 +40,10 @@
(body (h2 "Result")
(p ,(+ (get-number-1) (get-number-2))
(hr)
(p (URL "add-surflet.scm" "Make new calculation.") (br)
(URL "javascript:history.go(-2)" "New calculation (same session)")
(p (url "add-surflet.scm" "Make new calculation.") (br)
(url "javascript:history.go(-2)" "New calculation (same session)")
(br)
(URL "/" "Return to main menu."))))))
(url "/" "Return to main menu."))))))
"this string will never be evaluated")
))

View File

@ -31,8 +31,8 @@
(td ,submit-button))))
options)))
(hr)
(p (URL ,(return-address new-url) "Return to adminstration menu.") (br)
(URL "/" "Return to main menu."))))
(p (url ,(return-address new-url) "Return to adminstration menu.") (br)
(url "/" "Return to main menu."))))
)))
(define submit-timeout (make-submit-button "Change"))

View File

@ -70,7 +70,7 @@
(define (no-surflets)
`(p "Currently, there are no SUrflets loaded "
(URL ,(make-callback surflets) "(reload).")))
(url ,(make-callback surflets) "(reload).")))
(define (surflets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text ""))
@ -81,7 +81,7 @@
(h2 "SUrflets")
(p (font (@ (color "red")) ,update-text))))
(footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to main page")))
(url ,(make-callback return-to-main-page) "Return to main page")))
(actions '("unload" "unload all" "view sessions")))
(if (null? loaded-surflets)
(send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
@ -98,7 +98,7 @@
`(p "Note that unloading the SUrflet does not imply "
"the unloading of sessions of this SUrflet."
"This can be done on the "
(URL ,(make-callback sessions)
(url ,(make-callback sessions)
"sessions adminstration page."))
footer))
(if (null? selected-surflets)
@ -147,7 +147,7 @@
'(p "Currently, there are no sessions, "
"i.e. the administration SUrflet is no longer running. "
;; Can't use callback here, as there are no valid sessions left.
(URL "admin.scm" "Go back to main page.")))
(url "admin.scm" "Go back to main page.")))
(define (sessions req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text ""))
@ -161,7 +161,7 @@
(h2 "Sessions")
(p (font (@ (color "red")) ,update-text))))
(footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to main page")))
(url ,(make-callback return-to-main-page) "Return to main page")))
(actions '("kill"
"adjust timeout"
"view continuations"))
@ -210,11 +210,11 @@
(define (no-current-continuations session)
`((p "Currently, there are no continuations for this session. ")
(p "You may " (URL ,(make-callback
(p "You may " (url ,(make-callback
(lambda (req) (continuations (list session))))
"reload")
" this page or go back to the "
(URL ,(make-callback sessions) "session table overview."))))
(url ,(make-callback sessions) "session table overview."))))
(define (no-more-than-one-session title header1)
(send-html
@ -224,7 +224,7 @@
"one session at a time. This will be changed in "
"future revisions. Sorry for any inconvenience.")
(p "You may choose to go back to the "
(URL ,(make-callback sessions)
(url ,(make-callback sessions)
"sessions administration page")
" where you can choose one session.")))))
@ -252,10 +252,13 @@
(p (font (@ (color "red")) ,update-text)))))
(footer
`((hr)
(URL ,(make-callback sessions) "Return to sessions page.") (br)
(URL ,(make-callback return-to-main-page) "Return to main page.")))
(url ,(make-callback sessions)
"Return to sessions page.") (br)
(url ,(make-callback return-to-main-page)
"Return to main page.")))
(actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req)
(continuations-callback
(make-callback (lambda (req)
(continuations sessions)))))
(if (null? current-continuations)
(send-html `(html (title ,title)

View File

@ -12,11 +12,11 @@
(p "Choose one of the following submenus:")
(p
(ul
(li (URL "admin-handler.scm" "Set handler options..."))
(li (URL "admin-surflets.scm" "SUrflets..."))
(li (URL "admin-profiling.scm" "Profiling..."))))
(li (url "admin-handler.scm" "Set handler options..."))
(li (url "admin-surflets.scm" "SUrflets..."))
(li (url "admin-profiling.scm" "Profiling..."))))
(hr)
(p (URL "/" "Return to main menu.")))))
(p (url "/" "Return to main menu.")))))
(define (main req)
(send-html (main-page)))

View File

@ -40,8 +40,8 @@
(h2 "Result")
(p "You've entered " ,result ".")
(hr)
(p (URL "byte-input.scm" "Make new byte input.") (br)
(URL "/" "Return to main menu."))))))
(p (url "byte-input.scm" "Make new byte input.") (br)
(url "/" "Return to main menu."))))))
(define (get-byte-input)
(let* ((req (send-html/suspend
@ -54,7 +54,7 @@
,byte-input-fields
,(make-submit-button))
(hr)
(p (URL "/" "Return to main menu.")))))))
(p (url "/" "Return to main menu.")))))))
(bindings (get-bindings req)))
(input-field-value byte-input-fields bindings)))

View File

@ -66,7 +66,7 @@
(tr (td ,operator-input-field)
(td ,change-button)))
(hr)
(p (URL "/" "Return to main menu."))))))))
(p (url "/" "Return to main menu."))))))))
(bindings (get-bindings req)))
(let ((number1 (input-field-value number-field1 bindings))
(number2 (input-field-value number-field2 bindings)))
@ -105,8 +105,8 @@
(p ,number1 " " ,operator-symbol " " ,number2
" = " ,result)
(hr)
(p (URL "calculate.scm" "Make new calculation") (br)
(URL "/" "Return to main menu."))))))
(p (url "calculate.scm" "Make new calculation") (br)
(url "/" "Return to main menu."))))))
(define (main req)
(show-page (car *operator-alist*) #f #f)

View File

@ -29,8 +29,8 @@
`(html (body (p (h1 "THAT'S IT"))
(p ("That's it..."))
(hr)
(p (URL "news.scm" "See news again.") (br)
(URL "/" "Return to main menu."))))))
(p (url "news.scm" "See news again.") (br)
(url "/" "Return to main menu."))))))
(define (show-news-page news)
(send-html/suspend
@ -38,7 +38,7 @@
`(html (body (p (h1 ,news))
(a (@ href ,next-url) "read more...")
(hr)
(p (URL "news.scm" "See news again from beginning.") (br)
(URL "/" "Return to main menu.")))))))
(p (url "news.scm" "See news again from beginning.") (br)
(url "/" "Return to main menu.")))))))
))

View File

@ -469,13 +469,13 @@ spaceships of class " ,class ":")
,(return-links first-page-return-link main-return-link))))
(define main-return-link
'(URL "/" "Return to main menu."))
'(url "/" "Return to main menu."))
(define (previous-page-return-link prev)
`(URL ,prev "Return to previous page."))
`(url ,prev "Return to previous page."))
(define first-page-return-link
'(URL "/surflet/spaceship.scm" "Return to spaceship builder entry page."))
'(url "/surflet/spaceship.scm" "Return to spaceship builder entry page."))
(define (return-links . links)
`(p

View File

@ -3,34 +3,54 @@
surflets
httpd-responses)
(begin
(define global '())
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
(define (main req)
(let ((req (send-html/suspend
(set! global (cons 1 global))
(let* ((addr (make-annotated-address))
(req (send-html/suspend
(lambda (new-url)
`(html (body (h1 "This is from SUrflet")
(p "called " ,(length global) " times")
(URL ,(addr new-url "ab=ba")) (br)
(URL ,(addr new-url "be<ta")) (br)
(URL ,(addr new-url)) (br)
(abba)
(surflet-form
,new-url
POST
,select
'(input (@ (type "text") (name "TeST")))
,(make-submit-button))
(hr)
(p (URL "/" "Return to main menu."))
)))))
(save-k #f)
(done? #f))
(done? #f)
(bindings (get-bindings req))
(result
(cond
((returned-via? addr bindings) =>
(lambda (string)
(format #f "returned via annotated string ~s" string)))
(else
(format #f "~s" bindings)))))
(call-with-current-continuation
(lambda (k)
(set! save-k k)
13))
(set! global (cons 1 global))
(if (not done?)
(begin
(send-html/suspend
(lambda (continue)
`(html (body (h1 "Result")
,(format #f "~s" (get-bindings req)) (br)
(p "called " ,(length global) " times")
,result (br)
(URL ,continue "show results again")
(hr)
(p (URL "test.scm" "Test again.") (br)
@ -41,6 +61,7 @@
(send-html/finish
`(html (body (h1 "Result 2")
(p "called " ,(length global) " times")
,(format #f "~s" (get-bindings req))
(hr)
(p (URL "test.scm" "Test again.") (br)