suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Supporting multiple value returns in formlets

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-27 10:41:56 -06:00
parent 77aa7b041c
commit e258476748
5 changed files with 163 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/tests/web-server/formlets-test.ss
View File

@ -301,6 +301,73 @@
#f "127.0.0.1" 80 "127.0.0.1"))
(list "Jay" (make-date 10 6) (make-date 10 8))))))
; Multiple value formlets
(local [(define (date->xml m d)
(format "~a/~a" m d))
(define (submit t)
`(input ([type "submit"]) ,t))
(define date-formlet
(formlet
(div
"Month:" ,{input-int . => . month}
"Day:" ,{input-int . => . day})
(values month day)))
(define travel-formlet
(formlet
(div
"Name:" ,{input-string . => . name}
(div
"Arrive:" ,{date-formlet . => . (values arrive-m arrive-d)}
"Depart:" ,{date-formlet . => . (values depart-m depart-d)})
,@(list "1" "2" "3")
,(submit "Submit"))
(values name arrive-m arrive-d depart-m depart-d)))
(define-syntax-rule (check-equal?/values actual-expr expected-expr)
(call-with-values (lambda () actual-expr)
(lambda actual
(call-with-values (lambda () expected-expr)
(lambda expected
(check-equal? actual expected))))))]
(test-suite
"Date (values)"
(test-case "date->xml"
(check-equal? (date->xml 1 2)
"1/2"))
(test-case "date-formlet"
(check-equal? (formlet-display date-formlet)
'((div () "Month:" (input ((name "input_0") (type "text"))) "Day:" (input ((name "input_1") (type "text")))))))
(test-case "travel-formlet"
(check-equal? (formlet-display travel-formlet)
'((div
()
"Name:"
(input ((name "input_0") (type "text")))
(div
()
"Arrive:"
(div () "Month:" (input ((name "input_1") (type "text"))) "Day:" (input ((name "input_2") (type "text"))))
"Depart:"
(div () "Month:" (input ((name "input_3") (type "text"))) "Day:" (input ((name "input_4") (type "text")))))
"1"
"2"
"3"
(input ((type "submit")) "Submit")))))
(test-case "travel-formlet (proc)"
(check-equal?/values (formlet-process travel-formlet
(make-request #"GET" (string->url "http://test.com")
empty
(delay
(list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10")
(make-binding:form #"input_2" #"6")
(make-binding:form #"input_3" #"10")
(make-binding:form #"input_4" #"8")))
#f "127.0.0.1" 80 "127.0.0.1"))
(values "Jay" 10 6 10 8)))))
))
(require schemeunit/text-ui)

24
collects/web-server/formlets/lib.ss
View File

@ -13,13 +13,11 @@
(define (cross f p)
(lambda (i)
(let*-values ([(x1 g i) (f i)]
[(x2 q i) (p i)])
(let*-values ([(x1 a1 i) (f i)]
[(x2 a2 i) (p i)])
(values (append x1 x2)
(lambda (env)
(let ([ge (g env)]
[qe (q env)])
(ge qe)))
(call-with-values (lambda () (a2 env)) (a1 env)))
i))))
;; This is gross because OCaml auto-curries
@ -70,23 +68,25 @@
(define xexpr-forest/c
(listof pretty-xexpr/c))
(define (formlet/c c)
(define-syntax-rule (formlet/c* c)
(integer? . -> .
(values xexpr-forest/c
((listof binding?) . -> . (coerce-contract 'formlet/c c))
((listof binding?) . -> . c)
integer?)))
(define formlet*/c (formlet/c* any))
(define (formlet/c . c)
(formlet/c* (apply values (map (curry coerce-contract 'formlet/c) c))))
(define alpha any/c)
(define beta any/c)
(provide/contract
[xexpr-forest/c contract?]
[formlet/c (any/c . -> . contract?)]
[formlet*/c contract?]
[formlet/c (() () #:rest (listof any/c) . ->* . contract?)]
[pure (alpha
. -> . (formlet/c alpha))]
[cross ((formlet/c (alpha . -> . beta))
(formlet/c alpha)
. -> . (formlet/c beta))]
[cross ((formlet/c procedure?) formlet*/c . -> . formlet*/c)]
[cross* (((formlet/c (() () #:rest (listof alpha) . ->* . beta)))
() #:rest (listof (formlet/c alpha))
. ->* . (formlet/c beta))]
@ -95,4 +95,4 @@
[text (string? . -> . (formlet/c procedure?))]
[tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))]
[formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)]
[formlet-process ((formlet/c alpha) request? . -> . alpha)])
[formlet-process (formlet*/c request? . -> . any)])

6
collects/web-server/formlets/servlet.ss
View File

@ -4,9 +4,9 @@
"lib.ss")
(provide/contract
[send/formlet (((formlet/c any/c))
[send/formlet ((formlet*/c)
(#:wrap (pretty-xexpr/c . -> . response/c))
. ->* . any/c)])
. ->* . any)])
(define (send/formlet f
#:wrap
@ -23,7 +23,7 @@
,@(formlet-display f)))))))
(provide/contract
[embed-formlet (embed/url/c (formlet/c any/c) . -> . pretty-xexpr/c)])
[embed-formlet (embed/url/c formlet*/c . -> . pretty-xexpr/c)])
(define (embed-formlet embed/url f)
`(form ([action ,(embed/url

94
collects/web-server/formlets/syntax.ss
View File

@ -1,44 +1,52 @@
#lang scheme
(require (for-syntax scheme)
(require (for-syntax scheme syntax/parse)
"lib.ss"
(for-syntax "lib.ss"))
(define-syntax (#%# stx) (raise-syntax-error '#%# "Only allowed inside formlet" stx))
(define-for-syntax (cross-of stx)
(syntax-case stx (unquote unquote-splicing => #%#)
[s (string? (syntax->datum #'s))
(syntax/loc stx empty)]
[,(formlet . => . name) (syntax/loc stx name)]
[,e (syntax/loc stx empty)]
[,@e (syntax/loc stx empty)]
[(#%# n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]))
(syntax-parse
stx
#:literals (unquote unquote-splicing => #%# values)
[s:str
(syntax/loc stx empty)]
[,(formlet . => . (values name:id ...)) (syntax/loc stx (vector name ...))]
[,(formlet . => . name:id) (syntax/loc stx name)]
[,e (syntax/loc stx empty)]
[,@e (syntax/loc stx empty)]
[(#%# n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]))
(define-for-syntax (circ-of stx)
(syntax-case stx (unquote unquote-splicing => #%#)
[s (string? (syntax->datum #'s))
(syntax/loc stx (text s))]
[,(formlet . => . name) (syntax/loc stx formlet)]
[,e (syntax/loc stx (xml e))]
[,@e (syntax/loc stx (xml-forest e))]
[(#%# n ...)
(let ([n-cross (map cross-of (syntax->list #'(n ...)))])
(quasisyntax/loc stx
(cross*
(pure (match-lambda*
[(list #,@n-cross)
(list #,@n-cross)]))
#,@(map circ-of (syntax->list #'(n ...))))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx
(tag-xexpr `t `([k v] ...)
(syntax-parse
stx
#:literals (unquote unquote-splicing => #%# values)
[s:str
(syntax/loc stx (text s))]
[,(formlet . => . (values name:id ...)) (syntax/loc stx (cross (pure (lambda (name ...) (vector name ...))) formlet))]
[,(formlet . => . name:id) (syntax/loc stx formlet)]
[,e (syntax/loc stx (xml e))]
[,@e (syntax/loc stx (xml-forest e))]
[(#%# n ...)
(let ([n-cross (map cross-of (syntax->list #'(n ...)))])
(quasisyntax/loc stx
(cross*
(pure (match-lambda*
[(list #,@n-cross)
(list #,@n-cross)]))
#,@(map circ-of (syntax->list #'(n ...))))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx
(tag-xexpr `t `([k v] ...)
#,(circ-of (syntax/loc stx (#%# n ...)))))]
[(t n ...)
(quasisyntax/loc stx
(tag-xexpr `t empty
[(t n ...)
(quasisyntax/loc stx
(tag-xexpr `t empty
#,(circ-of (syntax/loc stx (#%# n ...)))))]))
(define-syntax (formlet stx)
@ -48,4 +56,22 @@
(cross (pure (match-lambda [#,(cross-of #'q) e]))
#,(circ-of #'q)))]))
(provide formlet)
(provide formlet #%#)
(require "input.ss")
(define date-formlet
(formlet
(div
"Month:" ,{input-int . => . month}
"Day:" ,{input-int . => . day})
(values month day)))
(define travel-formlet
(formlet
(div
"Name:" ,{input-string . => . name}
(div
"Arrive:" ,{date-formlet . => . (values arrive-m arrive-d)}
"Depart:" ,{date-formlet . => . (values depart-m depart-d)})
,@(list "1" "2" "3"))
(values name arrive-m arrive-d depart-m depart-d)))

32
collects/web-server/scribblings/formlets.scrbl
View File

@ -110,9 +110,15 @@ Most users will want to use the syntactic shorthand for creating @tech{formlet}s
@tech{formlet} given by @scheme[_formlet-expr]; the result of this processing this formlet is
available in the @scheme[yields-expr] as @scheme[_name].
@scheme[,{_formlet-expr . => . (values _name ...)}] embeds the
@tech{formlet} given by @scheme[_formlet-expr]; the results of this processing this formlet is
available in the @scheme[yields-expr] as @scheme[_name ...].
@scheme[(#%# _xexpr ...)] renders an @xexpr forest.
}
@defidform[#%#]{Only allowed inside @scheme[formlet].}
}
@section{Functional Usage}
@ -128,10 +134,10 @@ types. Refer to @secref["input-formlets"] for example low-level formlets using t
Equivalent to @scheme[(listof xexpr/c)]
}
@defproc[(formlet/c [content any/c]) contract?]{
@defproc[(formlet/c [content any/c] ...) contract?]{
Equivalent to @scheme[(integer? . -> .
(values xexpr-forest/c
((listof binding?) . -> . (coerce-contract 'formlet/c content))
((listof binding?) . -> . (values (coerce-contract 'formlet/c content) ...))
integer?))].
A @tech{formlet}'s internal representation is a function from an initial input number
@ -139,16 +145,20 @@ types. Refer to @secref["input-formlets"] for example low-level formlets using t
input number.
}
@defthing[formlet*/c contract?]{
Equivalent to @scheme[(formlet/c any/c ...)].
}
@defproc[(pure [value any/c]) (formlet/c any/c)]{
Constructs a @tech{formlet} that has no rendering and always returns @scheme[value] in
the processing stage.
}
@defproc[(cross [f (formlet/c (any/c . -> . any/c))]
[g (formlet/c any/c)])
(formlet/c any/c)]{
@defproc[(cross [f (formlet/c procedure?)]
[g (formlet/c any/c ...)])
(formlet/c any/c ...)]{
Constructs a @tech{formlet} with a rendering equal to the concatenation of the renderings of @tech{formlet}s @scheme[f] and @scheme[g];
a processing stage that applies @scheme[g]'s processing result to @scheme[f]'s processing result.
a processing stage that applies @scheme[g]'s processing results to @scheme[f]'s processing result.
}
@defproc[(cross* [f (formlet/c (() () #:rest (listof any/c) . ->* . any/c))]
@ -185,9 +195,9 @@ types. Refer to @secref["input-formlets"] for example low-level formlets using t
Renders @scheme[f].
}
@defproc[(formlet-process [f (formlet/c any/c)]
@defproc[(formlet-process [f (formlet/c any/c ...)]
[r request?])
any/c]{
(values any/c ...)]{
Runs the processing stage of @scheme[f] on the bindings in @scheme[r].
}
@ -310,13 +320,13 @@ These @tech{formlet}s are the main combinators for form input.
A few utilities are provided for using @tech{formlet}s in Web applications.
@defproc[(send/formlet [f (formlet/c any/c)]
@defproc[(send/formlet [f (formlet/c any/c ...)]
[#:wrap wrapper
(xexpr/c . -> . response/c)
(lambda (form-xexpr)
`(html (head (title "Form Entry"))
(body ,form-xexpr)))])
any/c]{
(values any/c ...)]{
Uses @scheme[send/suspend] to send @scheme[f]'s rendering (wrapped in a FORM tag whose action is
the continuation URL (wrapped again by @scheme[wrapper])) to the client.
When the form is submitted, the request is passed to the
@ -324,7 +334,7 @@ A few utilities are provided for using @tech{formlet}s in Web applications.
}
@defproc[(embed-formlet [embed/url embed/url/c]
[f (formlet/c any/c)])
[f (formlet/c any/c ...)])
xexpr/c]{
Like @scheme[send/formlet], but for use with @scheme[send/suspend/dispatch].
}