From 77aa7b041cee8079f09f0746ed958f74e2890ff4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 27 Apr 2010 09:47:39 -0600 Subject: [PATCH 1/3] Rewriting in a different order --- collects/meta/drdr/run-collect.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/drdr/run-collect.ss b/collects/meta/drdr/run-collect.ss index c4aaa3d221..68963571d9 100644 --- a/collects/meta/drdr/run-collect.ss +++ b/collects/meta/drdr/run-collect.ss @@ -123,8 +123,8 @@ (define cwd (path->string (current-directory))) (define (rewrite s) (regexp-replace** ([rev ""] - [home ""] [tmp ""] + [home ""] [cwd ""]) s)) From e25847674827c37d056b09c9ef409793596f0b88 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 27 Apr 2010 10:41:56 -0600 Subject: [PATCH 2/3] Supporting multiple value returns in formlets --- collects/tests/web-server/formlets-test.ss | 67 +++++++++++++ collects/web-server/formlets/lib.ss | 24 ++--- collects/web-server/formlets/servlet.ss | 6 +- collects/web-server/formlets/syntax.ss | 94 ++++++++++++------- .../web-server/scribblings/formlets.scrbl | 32 ++++--- 5 files changed, 163 insertions(+), 60 deletions(-) diff --git a/collects/tests/web-server/formlets-test.ss b/collects/tests/web-server/formlets-test.ss index 1d73f9c375..9cb6b61435 100644 --- a/collects/tests/web-server/formlets-test.ss +++ b/collects/tests/web-server/formlets-test.ss @@ -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) diff --git a/collects/web-server/formlets/lib.ss b/collects/web-server/formlets/lib.ss index f1945f2761..6e84a6d1a4 100644 --- a/collects/web-server/formlets/lib.ss +++ b/collects/web-server/formlets/lib.ss @@ -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)]) diff --git a/collects/web-server/formlets/servlet.ss b/collects/web-server/formlets/servlet.ss index 6d1d1f6827..2fd399abd9 100644 --- a/collects/web-server/formlets/servlet.ss +++ b/collects/web-server/formlets/servlet.ss @@ -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 diff --git a/collects/web-server/formlets/syntax.ss b/collects/web-server/formlets/syntax.ss index c586052d86..39fe249bc6 100644 --- a/collects/web-server/formlets/syntax.ss +++ b/collects/web-server/formlets/syntax.ss @@ -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))) diff --git a/collects/web-server/scribblings/formlets.scrbl b/collects/web-server/scribblings/formlets.scrbl index 376dd14926..f817ec6735 100644 --- a/collects/web-server/scribblings/formlets.scrbl +++ b/collects/web-server/scribblings/formlets.scrbl @@ -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]. } From 5b779d22ac1c3a967992f9e97bd31f2050f4e203 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 27 Apr 2010 11:00:24 -0600 Subject: [PATCH 3/3] slatex test, slatex contracts and props --- collects/meta/props | 1 + collects/slatex/{internal-doc.txt => README} | 0 collects/slatex/slatex-wrapper.ss | 10 +++- collects/tests/slatex/test.rkt | 63 ++++++++++++++++++++ 4 files changed, 72 insertions(+), 2 deletions(-) rename collects/slatex/{internal-doc.txt => README} (100%) create mode 100644 collects/tests/slatex/test.rkt diff --git a/collects/meta/props b/collects/meta/props index 1087c5d13e..3ddcbfcc8b 100644 --- a/collects/meta/props +++ b/collects/meta/props @@ -1798,6 +1798,7 @@ path/s is either such a string or a list of them. "collects/tests/scribble" responsible (eli mflatt) "collects/tests/srfi" responsible (noel chongkai jay) "collects/tests/srpersist" responsible (unknown) +"collects/tests/slatex" responsible (jay sstrickl) "collects/tests/syntax-color" responsible (sowens mflatt) "collects/tests/test-engine" responsible (kathyg) "collects/tests/unstable/generics.ss" responsible (jay) diff --git a/collects/slatex/internal-doc.txt b/collects/slatex/README similarity index 100% rename from collects/slatex/internal-doc.txt rename to collects/slatex/README diff --git a/collects/slatex/slatex-wrapper.ss b/collects/slatex/slatex-wrapper.ss index 4cd37d50f9..83fa80acd2 100644 --- a/collects/slatex/slatex-wrapper.ss +++ b/collects/slatex/slatex-wrapper.ss @@ -1,12 +1,18 @@ (module slatex-wrapper scheme/base (require mzlib/file + scheme/contract mzlib/process mzlib/sendevent "slatex.ss") - (provide slatex latex pdf-slatex pdf-latex slatex/no-latex - filename->latex-filename) + (provide/contract + [slatex (string? . -> . boolean?)] + [pdf-slatex (string? . -> . boolean?)] + [slatex/no-latex (string? . -> . boolean?)] + [latex (string? . -> . boolean?)] + [pdf-latex (string? . -> . boolean?)] + [filename->latex-filename (string? . -> . string?)]) (define (add-suffix p s) (path->string diff --git a/collects/tests/slatex/test.rkt b/collects/tests/slatex/test.rkt new file mode 100644 index 0000000000..c24d2c2e06 --- /dev/null +++ b/collects/tests/slatex/test.rkt @@ -0,0 +1,63 @@ +#lang racket +(require slatex/slatex-wrapper + tests/eli-tester + scheme/runtime-path) + +(define-runtime-path slatex-file-pth '(lib "slatex")) +(define slatex-pth (path-only slatex-file-pth)) + +(define tmp-file (build-path (current-directory) "test.tex") + #;(make-temporary-file "slatex~a.tex" #f (current-directory))) + +(test + (putenv "TEXINPUTS" (format "~a:" (path->string slatex-pth))) + tmp-file + + (with-output-to-file tmp-file #:exists 'truncate/replace + (lambda () + (display #<string tmp-file)) + + (with-handlers ([exn:fail:filesystem? void]) + (delete-file (path-replace-suffix tmp-file #".aux"))) + (with-handlers ([exn:fail:filesystem? void]) + (delete-file (path-replace-suffix tmp-file #".log"))) + (with-handlers ([exn:fail:filesystem? void]) + (delete-file (path-replace-suffix tmp-file #".dvi"))) + + (delete-file tmp-file)) + \ No newline at end of file