Supporting arguments in dispatch pattern arguments
svn: r18724
This commit is contained in:
parent
7b61ba023d
commit
2a87df9e5c
|
@ -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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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?]{
|
||||||
|
|
Loading…
Reference in New Issue
Block a user