From 2a87df9e5c15e3320176cc758a006ad5c4b43842 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Fri, 2 Apr 2010 20:55:36 +0000
Subject: [PATCH] Supporting arguments in dispatch pattern arguments

svn: r18724
---
 collects/tests/web-server/dispatch-test.ss    | 93 +++++++++++++------
 collects/web-server/dispatch/bidi-match.ss    |  6 +-
 collects/web-server/dispatch/pattern.ss       | 12 +--
 collects/web-server/dispatch/syntax.ss        | 28 +++++-
 .../web-server/scribblings/dispatch.scrbl     | 20 ++++
 5 files changed, 115 insertions(+), 44 deletions(-)

diff --git a/collects/tests/web-server/dispatch-test.ss b/collects/tests/web-server/dispatch-test.ss
index 96b7e28c2e..720f5ecb26 100644
--- a/collects/tests/web-server/dispatch-test.ss
+++ b/collects/tests/web-server/dispatch-test.ss
@@ -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)
diff --git a/collects/web-server/dispatch/bidi-match.ss b/collects/web-server/dispatch/bidi-match.ss
index e0514d96d6..5e2a9b184f 100644
--- a/collects/web-server/dispatch/bidi-match.ss
+++ b/collects/web-server/dispatch/bidi-match.ss
@@ -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)
diff --git a/collects/web-server/dispatch/pattern.ss b/collects/web-server/dispatch/pattern.ss
index 30e04a56ca..beb7243851 100644
--- a/collects/web-server/dispatch/pattern.ss
+++ b/collects/web-server/dispatch/pattern.ss
@@ -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)))
 
diff --git a/collects/web-server/dispatch/syntax.ss b/collects/web-server/dispatch/syntax.ss
index 8069d87ce6..005bfc9972 100644
--- a/collects/web-server/dispatch/syntax.ss
+++ b/collects/web-server/dispatch/syntax.ss
@@ -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)
diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl
index ce8c8bd54c..ad3da5996f 100644
--- a/collects/web-server/scribblings/dispatch.scrbl
+++ b/collects/web-server/scribblings/dispatch.scrbl
@@ -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?]{