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

Supporting arguments in dispatch pattern arguments

Browse Source 
svn: r18724
This commit is contained in:
Jay McCarthy 2010-04-02 20:55:36 +00:00
parent 7b61ba023d
commit 2a87df9e5c
5 changed files with 115 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/tests/web-server/dispatch-test.ss
View File

@ -21,17 +21,17 @@
"Dispatch" "Dispatch"
#;(local #;(local
[(define-syntax test-match=> [(define-syntax test-match=>
(syntax-rules () (syntax-rules ()
[(_ val pat res) [(_ val pat res)
(test-equal? (format "~S" 'pat) (test-equal? (format "~S" 'pat)
(match=> val [pat => (lambda x x)]) (match=> val [pat => (lambda x x)])
res)]))] res)]))]
(test-suite (test-suite
"match" "match"
(test-match=> (list 1 2) (list a b) (list 1 2)) (test-match=> (list 1 2) (list a b) (list 1 2))
(test-match=> (list 1 2) (list _ b) (list 2)))) (test-match=> (list 1 2) (list _ b) (list 2))))
(test-suite (test-suite
"coercion" "coercion"
@ -193,11 +193,11 @@
'string-arg) 'string-arg)
(check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg)))))))))) (check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))))))
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((... ...))))) (test-exn "dispatch-pattern? ..." exn? (lambda () (dispatch-pattern? #'((... ...)))))
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'("foo" (... ...))))) (test-exn "dispatch-pattern? foo ..." exn? (lambda () (dispatch-pattern? #'("foo" (... ...)))))
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a) (... ...))))) (test-not-false "dispatch-pattern? integer-arg a ..." (dispatch-pattern? #'((integer-arg a) (... ...))))
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a))))) (test-not-false "dispatch-pattern? integer-arg a " (dispatch-pattern? #'((integer-arg a))))
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((list a b) (... ...))))) (test-not-false "dispatch-pattern? list a b" (dispatch-pattern? #'((list a b) (... ...))))
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg) (... ...)))) (test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg) (... ...))))
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg)))) (test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg))))
(test-not-false "dispatch-pattern?" (dispatch-pattern? #'("foo"))) (test-not-false "dispatch-pattern?" (dispatch-pattern? #'("foo")))
@ -206,75 +206,108 @@
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'("foo" (... ...))))) (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'("foo" (... ...)))))
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a) (... ...)))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a) (... ...))))
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a)))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a))))
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((list a b) (... ...))))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((list a b) (... ...))))
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg) (... ...))))) (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg) (... ...)))))
(test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg))))) (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg)))))
(test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo")))) (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo"))))
(local [(define-syntax test-arg (local [(define-syntax test-arg
(syntax-rules () (syntax-rules ()
[(_ arg [(_ (arg arg-a ...)
([in-expr out-expr] ...) ([in-expr out-expr] ...)
[in-fail-expr ...] [in-fail-expr ...]
[out-fail-expr ...]) [out-fail-expr ...])
(test-suite (format "~S" 'arg) (test-suite (format "~S" 'arg)
(test-equal? (format "in ~S" in-expr) (test-equal? (format "in ~S" in-expr)
(syntax-parameterize ([bidi-match-going-in? #t]) (syntax-parameterize ([bidi-match-going-in? #t])
(match in-expr [(arg a) a])) (match in-expr [(arg arg-a ... a) a]))
out-expr) out-expr)
... ...
(test-equal? (format "out ~S" out-expr) (test-equal? (format "out ~S" out-expr)
(syntax-parameterize ([bidi-match-going-in? #f]) (syntax-parameterize ([bidi-match-going-in? #f])
(match out-expr [(arg a) a])) (match out-expr [(arg arg-a ... a) a]))
in-expr) in-expr)
... ...
(test-false (format "in-fail ~S" in-fail-expr) (test-false (format "in-fail ~S" in-fail-expr)
(syntax-parameterize ([bidi-match-going-in? #t]) (syntax-parameterize ([bidi-match-going-in? #t])
(match in-fail-expr [(arg a) a] [_ #f]))) (match in-fail-expr [(arg arg-a ... a) a] [_ #f])))
... ...
(test-false (format "out-fail ~S" out-fail-expr) (test-false (format "out-fail ~S" out-fail-expr)
(syntax-parameterize ([bidi-match-going-in? #f]) (syntax-parameterize ([bidi-match-going-in? #f])
(match out-fail-expr [(arg a) a] [_ #f]))) (match out-fail-expr [(arg arg-a ... a) a] [_ #f])))
...)]))] ...)]))]
(test-suite (test-suite
"url-patterns" "url-patterns"
(test-arg number-arg (test-arg (number-arg)
(["1" 1] (["1" 1]
["2.3" 2.3] ["2.3" 2.3]
["+inf.0" +inf.0]) ["+inf.0" +inf.0])
["a"] ["a"]
['a #t]) ['a #t])
(test-arg integer-arg (test-arg (integer-arg)
(["1" 1]) (["1" 1])
["a" "2.3" "+inf.0"] ["a" "2.3" "+inf.0"]
['a #t 2.3 +inf.0]) ['a #t 2.3 +inf.0])
(test-arg real-arg (test-arg (real-arg)
(["1" 1] (["1" 1]
["2.3" 2.3] ["2.3" 2.3]
["+inf.0" +inf.0]) ["+inf.0" +inf.0])
["a"] ["a"]
['a #t]) ['a #t])
(test-arg string-arg (test-arg (string-arg)
(["1" "1"] (["1" "1"]
["foo" "foo"] ["foo" "foo"]
["/" "/"]) ["/" "/"])
[] []
['a #t 5]) ['a #t 5])
(test-arg symbol-arg (test-arg (symbol-arg)
(["1" '|1|] (["1" '|1|]
["foo" 'foo] ["foo" 'foo]
["/" '/]) ["/" '/])
[] []
["a" #t 5]))) ["a" #t 5])
(local [(define-match-expander const-m
(syntax-rules ()
[(_ v id) (? (curry equal? v) id)]))
(define-bidi-match-expander const-arg const-m const-m)]
(test-arg (const-arg "1")
(["1" "1"])
["2"]
["2"]))))
(test-suite (test-suite
"syntax" "syntax"
(local
[(define (list-posts req) `(list-posts))
(define (review-post req p) `(review-post ,p))
(define (review-archive req y m) `(review-archive ,y ,m))
(define-values (blog-dispatch blog-url blog-applies?)
(dispatch-rules+applies
[("") list-posts]
[() list-posts]
[("posts" (string-arg)) review-post]
[("archive" (integer-arg) (integer-arg)) review-archive]))
(define (test-blog-dispatch url)
(test-not-false url (blog-applies? (test-request (string->url url)))))
(define (test-blog-dispatch/exn url)
(test-false url (blog-applies? (test-request (string->url url)))))]
(test-blog-dispatch "http://www.example.com")
(test-blog-dispatch "http://www.example.com/")
(test-blog-dispatch "http://www.example.com/posts/hello-world")
(test-blog-dispatch "http://www.example.com/archive/2008/02")
(test-blog-dispatch/exn "http://www.example.com/posts")
(test-blog-dispatch/exn "http://www.example.com/archive/post/02")
(test-blog-dispatch/exn "http://www.example.com/archive/2008/post")
(test-blog-dispatch/exn "http://www.example.com/foo"))
(local (local
[(define (list-posts req) `(list-posts)) [(define (list-posts req) `(list-posts))
(define (review-post req p) `(review-post ,p)) (define (review-post req p) `(review-post ,p))
@ -425,5 +458,5 @@
#;(test-serve/dispatch) #;(test-serve/dispatch)
#;(require (planet schematics/schemeunit:3/text-ui)) (require schemeunit/text-ui)
#;(run-tests all-dispatch-tests) (run-tests all-dispatch-tests)

6
collects/web-server/dispatch/bidi-match.ss
View File

@ -10,10 +10,10 @@
(define-match-expander bidi-id (define-match-expander bidi-id
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ arg (... ...) id)
(if (syntax-parameter-value #'bidi-match-going-in?) (if (syntax-parameter-value #'bidi-match-going-in?)
(syntax/loc stx (in-expander id)) (syntax/loc stx (in-expander arg (... ...) id))
(syntax/loc stx (out-expander id)))]))))])) (syntax/loc stx (out-expander arg (... ...) id)))]))))]))
(provide bidi-match-going-in? (provide bidi-match-going-in?
define-bidi-match-expander) define-bidi-match-expander)

12
collects/web-server/dispatch/pattern.ss
View File

@ -14,7 +14,7 @@
(define (dispatch/no-...? stx) (define (dispatch/no-...? stx)
(syntax-case stx () (syntax-case stx ()
[() #t] [() #t]
[((bidi) . rest-stx) [((bidi arg ...) . rest-stx)
(dispatch/...? #'rest-stx)] (dispatch/...? #'rest-stx)]
[(string . rest-stx) [(string . rest-stx)
(string-syntax? #'string) (string-syntax? #'string)
@ -22,7 +22,7 @@
(define (dispatch/...? stx) (define (dispatch/...? stx)
(syntax-case stx () (syntax-case stx ()
[() #t] [() #t]
[((bidi) . rest-stx) [((bidi arg ...) . rest-stx)
(dispatch/...? #'rest-stx)] (dispatch/...? #'rest-stx)]
[(string . rest-stx) [(string . rest-stx)
(string-syntax? #'string) (string-syntax? #'string)
@ -35,7 +35,7 @@
(define (dispatch/no-...? stx) (define (dispatch/no-...? stx)
(syntax-case stx () (syntax-case stx ()
[() #t] [() #t]
[((bidi id) . rest-stx) [((bidi arg ... id) . rest-stx)
(identifier? #'id) (identifier? #'id)
(dispatch/...? #'rest-stx)] (dispatch/...? #'rest-stx)]
[(string . rest-stx) [(string . rest-stx)
@ -44,7 +44,7 @@
(define (dispatch/...? stx) (define (dispatch/...? stx)
(syntax-case stx () (syntax-case stx ()
[() #t] [() #t]
[((bidi id) . rest-stx) [((bidi arg ... id) . rest-stx)
(identifier? #'id) (identifier? #'id)
(dispatch/...? #'rest-stx)] (dispatch/...? #'rest-stx)]
[(string . rest-stx) [(string . rest-stx)
@ -78,9 +78,9 @@
[(...? pp) [(...? pp)
pp] pp]
[else [else
(with-syntax ([(bidi-id) pp] (with-syntax ([(bidi-id arg ...) pp]
[id ppi]) [id ppi])
(syntax/loc pp (bidi-id id)))])) (syntax/loc pp (bidi-id arg ... id)))]))
(syntax->list pps) (syntax->list pps)
(generate-temporaries pps))) (generate-temporaries pps)))

28
collects/web-server/dispatch/syntax.ss
View File

@ -33,11 +33,11 @@
([((path-pat-id ...) ...) ([((path-pat-id ...) ...)
(map (lambda (pp/is) (map (lambda (pp/is)
(map (lambda (bs) (map (lambda (bs)
(with-syntax ([(bidi-id id) bs]) (with-syntax ([(bidi-id arg ... id) bs])
#'id)) #'id))
(filter (lambda (pp/i) (filter (lambda (pp/i)
(syntax-case pp/i () (syntax-case pp/i ()
[(bidi-id id) #t] [(bidi-id arg ... id) #t]
[_ #f])) [_ #f]))
(syntax->list pp/is)))) (syntax->list pp/is))))
(syntax->list #'((path-pat/id ...) ...)))]) (syntax->list #'((path-pat/id ...) ...)))])
@ -73,7 +73,7 @@
(for/list ([pp/i (dispatch-pattern-not-... pp/is)] (for/list ([pp/i (dispatch-pattern-not-... pp/is)]
[next-...? (dispatch-pattern-next-...? pp/is)]) [next-...? (dispatch-pattern-next-...? pp/is)])
(with-syntax ([pp pp/i] (with-syntax ([pp pp/i]
[(bidi-id id) pp/i]) [(bidi-id arg ... id) pp/i])
(if next-...? (if next-...?
(syntax/loc pp/i (list pp (... ...))) (syntax/loc pp/i (list pp (... ...)))
pp/i)))) pp/i))))
@ -89,7 +89,7 @@
(with-syntax ([pp pp/i]) (with-syntax ([pp pp/i])
(if (string-syntax? pp/i) (if (string-syntax? pp/i)
(syntax/loc pp/i (list pp)) (syntax/loc pp/i (list pp))
(with-syntax ([(bidi-id id) pp/i]) (with-syntax ([(bidi-id arg ... id) pp/i])
(if next-...? (if next-...?
(syntax/loc pp/i id) (syntax/loc pp/i id)
(syntax/loc pp/i (list id)))))))) (syntax/loc pp/i (list id))))))))
@ -122,6 +122,24 @@
... ...
[else default-else]))])) [else default-else]))]))
(define (dispatch-succ . _) #t)
(define (dispatch-fail . _) #f)
(define-syntax-rule (dispatch-rules+applies
[pat fun]
...)
(let-values ([(dispatch url)
(dispatch-rules
[pat fun]
...)]
[(applies? _)
(dispatch-rules
[pat dispatch-succ]
...
[else dispatch-fail])])
(values dispatch url applies?)))
(provide dispatch-case (provide dispatch-case
dispatch-url dispatch-url
dispatch-rules) dispatch-rules
dispatch-rules+applies)

20
collects/web-server/scribblings/dispatch.scrbl
View File

@ -80,6 +80,7 @@ After mastering the world of blogging software, you decide to put the ubiquitous
(dispatch-rules (dispatch-rules
[((integer-arg) ...) sum] [((integer-arg) ...) sum]
[else (lambda (req) (sum req empty))])) [else (lambda (req) (sum req empty))]))
(define (sum req is) (define (sum req is)
(apply + is)) (apply + is))
@ -121,6 +122,21 @@ After mastering the world of blogging software, you decide to put the ubiquitous
(bidi-match-expander ... . dispatch-pattern) (bidi-match-expander ... . dispatch-pattern)
(bidi-match-expander . dispatch-pattern)] (bidi-match-expander . dispatch-pattern)]
@defform*[#:literals (else)
[(dispatch-rules+applies
[dispatch-pattern dispatch-fun]
...
[else else-fun])
(dispatch-rules+applies
[dispatch-pattern dispatch-fun]
...)]
#:contracts
([else-fun (request? . -> . response/c)]
[dispatch-fun (request? any/c ... . -> . response/c)])]{
Like @scheme[dispatch-rules], except returns a third value with the contract @scheme[(request? . -> . boolean?)] that returns
@scheme[#t] if the dispatching rules apply to the request and @scheme[#f] otherwise.
}
@defform*[#:literals (else) @defform*[#:literals (else)
[(dispatch-case [(dispatch-case
[dispatch-pattern dispatch-fun] [dispatch-pattern dispatch-fun]
@ -183,6 +199,10 @@ You can create new URL component patterns by defining @tech{bi-directional match
Binds @scheme[id] to a @deftech{bi-directional match expander} Binds @scheme[id] to a @deftech{bi-directional match expander}
where @scheme[in-xform] is a match expander (defined by @scheme[define-match-expander]) that is used when parsing URLs where @scheme[in-xform] is a match expander (defined by @scheme[define-match-expander]) that is used when parsing URLs
and @scheme[out-xform] is one used when generating URLs. and @scheme[out-xform] is one used when generating URLs.
Both @scheme[in-xform] and @scheme[out-xform] should use the syntax @scheme[(_xform arg ... _id)] where the @scheme[arg]s are
specific to @scheme[id] and compatible with both @scheme[in-xform] and @scheme[out-xform]. @scheme[_id] will typically be provided
automatically by @scheme[dispatch-rules].
} }
@defidform[bidi-match-going-in?]{ @defidform[bidi-match-going-in?]{