Supporting arguments in dispatch pattern arguments
svn: r18724
This commit is contained in:
Jay McCarthy
parent
7b61ba023d
commit
2a87df9e5c
|
|
@ -21,17 +21,17 @@
|
|||
"Dispatch"
|
||||
|
||||
#;(local
|
||||
[(define-syntax test-match=>
|
||||
(syntax-rules ()
|
||||
[(_ val pat res)
|
||||
(test-equal? (format "~S" 'pat)
|
||||
(match=> val [pat => (lambda x x)])
|
||||
res)]))]
|
||||
(test-suite
|
||||
"match"
|
||||
|
||||
(test-match=> (list 1 2) (list a b) (list 1 2))
|
||||
(test-match=> (list 1 2) (list _ b) (list 2))))
|
||||
[(define-syntax test-match=>
|
||||
(syntax-rules ()
|
||||
[(_ val pat res)
|
||||
(test-equal? (format "~S" 'pat)
|
||||
(match=> val [pat => (lambda x x)])
|
||||
res)]))]
|
||||
(test-suite
|
||||
"match"
|
||||
|
||||
(test-match=> (list 1 2) (list a b) (list 1 2))
|
||||
(test-match=> (list 1 2) (list _ b) (list 2))))
|
||||
|
||||
(test-suite
|
||||
"coercion"
|
||||
|
|
@ -193,11 +193,11 @@
|
|||
'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? #'("foo" (... ...)))))
|
||||
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a) (... ...)))))
|
||||
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a)))))
|
||||
(test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((list a b) (... ...)))))
|
||||
(test-exn "dispatch-pattern? ..." exn? (lambda () (dispatch-pattern? #'((... ...)))))
|
||||
(test-exn "dispatch-pattern? foo ..." exn? (lambda () (dispatch-pattern? #'("foo" (... ...)))))
|
||||
(test-not-false "dispatch-pattern? integer-arg a ..." (dispatch-pattern? #'((integer-arg a) (... ...))))
|
||||
(test-not-false "dispatch-pattern? integer-arg a " (dispatch-pattern? #'((integer-arg a))))
|
||||
(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? #'("foo")))
|
||||
|
|
@ -206,75 +206,108 @@
|
|||
(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-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-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo"))))
|
||||
|
||||
(local [(define-syntax test-arg
|
||||
(syntax-rules ()
|
||||
[(_ arg
|
||||
[(_ (arg arg-a ...)
|
||||
([in-expr out-expr] ...)
|
||||
[in-fail-expr ...]
|
||||
[out-fail-expr ...])
|
||||
(test-suite (format "~S" 'arg)
|
||||
(test-equal? (format "in ~S" in-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #t])
|
||||
(match in-expr [(arg a) a]))
|
||||
(match in-expr [(arg arg-a ... a) a]))
|
||||
out-expr)
|
||||
...
|
||||
(test-equal? (format "out ~S" out-expr)
|
||||
(syntax-parameterize ([bidi-match-going-in? #f])
|
||||
(match out-expr [(arg a) a]))
|
||||
(match out-expr [(arg arg-a ... a) a]))
|
||||
in-expr)
|
||||
...
|
||||
(test-false (format "in-fail ~S" in-fail-expr)
|
||||
(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)
|
||||
(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
|
||||
"url-patterns"
|
||||
|
||||
(test-arg number-arg
|
||||
(test-arg (number-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg integer-arg
|
||||
(test-arg (integer-arg)
|
||||
(["1" 1])
|
||||
["a" "2.3" "+inf.0"]
|
||||
['a #t 2.3 +inf.0])
|
||||
|
||||
(test-arg real-arg
|
||||
(test-arg (real-arg)
|
||||
(["1" 1]
|
||||
["2.3" 2.3]
|
||||
["+inf.0" +inf.0])
|
||||
["a"]
|
||||
['a #t])
|
||||
|
||||
(test-arg string-arg
|
||||
(test-arg (string-arg)
|
||||
(["1" "1"]
|
||||
["foo" "foo"]
|
||||
["/" "/"])
|
||||
[]
|
||||
['a #t 5])
|
||||
|
||||
(test-arg symbol-arg
|
||||
(test-arg (symbol-arg)
|
||||
(["1" '|1|]
|
||||
["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
|
||||
"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
|
||||
[(define (list-posts req) `(list-posts))
|
||||
(define (review-post req p) `(review-post ,p))
|
||||
|
|
@ -425,5 +458,5 @@
|
|||
|
||||
#;(test-serve/dispatch)
|
||||
|
||||
#;(require (planet schematics/schemeunit:3/text-ui))
|
||||
#;(run-tests all-dispatch-tests)
|
||||
(require schemeunit/text-ui)
|
||||
(run-tests all-dispatch-tests)
|
||||
|
|
|
|||
|
|
@ -10,10 +10,10 @@
|
|||
(define-match-expander bidi-id
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
[(_ arg (... ...) id)
|
||||
(if (syntax-parameter-value #'bidi-match-going-in?)
|
||||
(syntax/loc stx (in-expander id))
|
||||
(syntax/loc stx (out-expander id)))]))))]))
|
||||
(syntax/loc stx (in-expander arg (... ...) id))
|
||||
(syntax/loc stx (out-expander arg (... ...) id)))]))))]))
|
||||
|
||||
(provide bidi-match-going-in?
|
||||
define-bidi-match-expander)
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(define (dispatch/no-...? stx)
|
||||
(syntax-case stx ()
|
||||
[() #t]
|
||||
[((bidi) . rest-stx)
|
||||
[((bidi arg ...) . rest-stx)
|
||||
(dispatch/...? #'rest-stx)]
|
||||
[(string . rest-stx)
|
||||
(string-syntax? #'string)
|
||||
|
|
@ -22,7 +22,7 @@
|
|||
(define (dispatch/...? stx)
|
||||
(syntax-case stx ()
|
||||
[() #t]
|
||||
[((bidi) . rest-stx)
|
||||
[((bidi arg ...) . rest-stx)
|
||||
(dispatch/...? #'rest-stx)]
|
||||
[(string . rest-stx)
|
||||
(string-syntax? #'string)
|
||||
|
|
@ -35,7 +35,7 @@
|
|||
(define (dispatch/no-...? stx)
|
||||
(syntax-case stx ()
|
||||
[() #t]
|
||||
[((bidi id) . rest-stx)
|
||||
[((bidi arg ... id) . rest-stx)
|
||||
(identifier? #'id)
|
||||
(dispatch/...? #'rest-stx)]
|
||||
[(string . rest-stx)
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
(define (dispatch/...? stx)
|
||||
(syntax-case stx ()
|
||||
[() #t]
|
||||
[((bidi id) . rest-stx)
|
||||
[((bidi arg ... id) . rest-stx)
|
||||
(identifier? #'id)
|
||||
(dispatch/...? #'rest-stx)]
|
||||
[(string . rest-stx)
|
||||
|
|
@ -78,9 +78,9 @@
|
|||
[(...? pp)
|
||||
pp]
|
||||
[else
|
||||
(with-syntax ([(bidi-id) pp]
|
||||
(with-syntax ([(bidi-id arg ...) pp]
|
||||
[id ppi])
|
||||
(syntax/loc pp (bidi-id id)))]))
|
||||
(syntax/loc pp (bidi-id arg ... id)))]))
|
||||
(syntax->list pps)
|
||||
(generate-temporaries pps)))
|
||||
|
||||
|
|
|
|||
|
|
@ -33,11 +33,11 @@
|
|||
([((path-pat-id ...) ...)
|
||||
(map (lambda (pp/is)
|
||||
(map (lambda (bs)
|
||||
(with-syntax ([(bidi-id id) bs])
|
||||
(with-syntax ([(bidi-id arg ... id) bs])
|
||||
#'id))
|
||||
(filter (lambda (pp/i)
|
||||
(syntax-case pp/i ()
|
||||
[(bidi-id id) #t]
|
||||
[(bidi-id arg ... id) #t]
|
||||
[_ #f]))
|
||||
(syntax->list pp/is))))
|
||||
(syntax->list #'((path-pat/id ...) ...)))])
|
||||
|
|
@ -73,7 +73,7 @@
|
|||
(for/list ([pp/i (dispatch-pattern-not-... pp/is)]
|
||||
[next-...? (dispatch-pattern-next-...? pp/is)])
|
||||
(with-syntax ([pp pp/i]
|
||||
[(bidi-id id) pp/i])
|
||||
[(bidi-id arg ... id) pp/i])
|
||||
(if next-...?
|
||||
(syntax/loc pp/i (list pp (... ...)))
|
||||
pp/i))))
|
||||
|
|
@ -89,7 +89,7 @@
|
|||
(with-syntax ([pp pp/i])
|
||||
(if (string-syntax? pp/i)
|
||||
(syntax/loc pp/i (list pp))
|
||||
(with-syntax ([(bidi-id id) pp/i])
|
||||
(with-syntax ([(bidi-id arg ... id) pp/i])
|
||||
(if next-...?
|
||||
(syntax/loc pp/i id)
|
||||
(syntax/loc pp/i (list id))))))))
|
||||
|
|
@ -122,6 +122,24 @@
|
|||
...
|
||||
[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
|
||||
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
|
||||
[((integer-arg) ...) sum]
|
||||
[else (lambda (req) (sum req empty))]))
|
||||
|
||||
(define (sum req 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)]
|
||||
|
||||
@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)
|
||||
[(dispatch-case
|
||||
[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}
|
||||
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.
|
||||
|
||||
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?]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user