From 676f744c1d6ae22e8e17c7ec37e54e3b3de0d8fc Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 27 Mar 2012 12:21:00 -0500
Subject: [PATCH] add 'match-pattern?'

---
 collects/redex/private/matcher.rkt            |  6 +++++
 .../redex/private/reduction-semantics.rkt     | 27 +++++++++++--------
 collects/redex/reduction-semantics.rkt        |  1 +
 collects/redex/scribblings/ref.scrbl          |  7 +++++
 4 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt
index caa1b22172..411b559f76 100644
--- a/collects/redex/private/matcher.rkt
+++ b/collects/redex/private/matcher.rkt
@@ -601,6 +601,11 @@ See match-a-pattern.rkt for more details
       [`(list ,pats ...) #f]
       [(? (compose not pair?)) #t])))
 
+;; match-pattern? : compiled-pattern exp -> boolean
+(define (match-pattern? compiled-pattern exp)
+  (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)])
+    (and results #t)))
+
 ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
 (define (match-pattern compiled-pattern exp)
   (let ([results ((compiled-pattern-cp compiled-pattern) exp #f)])
@@ -1952,6 +1957,7 @@ See match-a-pattern.rkt for more details
 
 (provide/contract
  (match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?))))
+ (match-pattern? (compiled-pattern? any/c . -> . boolean?))
  (compile-pattern (-> compiled-lang? any/c boolean?
                       compiled-pattern?))
  
diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 47d7b246ba..19f86b23be 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1009,7 +1009,10 @@
                   (reduction-relation-make-procs subj))])
           (make-coverage subj h))))]))
 
-(define-syntax (test-match stx)
+(define-syntax (test-match stx) (test-match/both stx #f))
+(define-syntax (test-match? stx) (test-match/both stx #t))
+
+(define-for-syntax (test-match/both stx boolean-only?)
   (syntax-case stx ()
     [(form-name lang-exp pattern)
      (identifier? #'lang-exp)
@@ -1019,8 +1022,7 @@
                       (rewrite-side-conditions/check-errs nts what #t #'pattern)])
          (with-syntax ([binders (map syntax-e (syntax->list #'(vars ...)))]
                        [name (syntax-local-infer-name stx)])
-           (syntax 
-            (do-test-match lang-exp `side-condition-rewritten 'binders 'name)))))]
+           #`(do-test-match lang-exp `side-condition-rewritten 'binders 'name #,boolean-only?))))]
     [(form-name lang-exp pattern expression)
      (identifier? #'lang-exp)
      (syntax 
@@ -1032,7 +1034,7 @@
 
 (define-struct match (bindings) #:inspector #f)
 
-(define (do-test-match lang pat binders context-name)
+(define (do-test-match lang pat binders context-name boolean-only?)
   (unless (compiled-lang? lang)
     (error 'redex-match "expected first argument to be a language, got ~e" lang))
   (define name (or context-name
@@ -1040,13 +1042,15 @@
                         pat)))
   (define cpat (compile-pattern lang pat #t))
   (define redex-match-proc
-    (λ (exp)
-      (let ([ans (match-pattern cpat exp)])
-        (and ans
-             (map (λ (m) (make-match (sort-bindings 
-                                      (filter (λ (x) (memq (bind-name x) binders))
-                                              (bindings-table (mtch-bindings m))))))
-                  ans)))))
+    (if boolean-only?
+        (λ (exp) (match-pattern? cpat exp))
+        (λ (exp)
+          (let ([ans (match-pattern cpat exp)])
+            (and ans
+                 (map (λ (m) (make-match (sort-bindings 
+                                          (filter (λ (x) (memq (bind-name x) binders))
+                                                  (bindings-table (mtch-bindings m))))))
+                      ans))))))
   (if name
       (procedure-rename redex-match-proc name)
       redex-match-proc))
@@ -2369,6 +2373,7 @@
          (struct-out binds))
 
 (provide test-match
+         test-match?
          term-match
          term-match/single
          redex-let 
diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt
index c1e584f278..88bb7b0e9f 100644
--- a/collects/redex/reduction-semantics.rkt
+++ b/collects/redex/reduction-semantics.rkt
@@ -40,6 +40,7 @@
          check-redudancy)
 
 (provide (rename-out [test-match redex-match])
+         (rename-out [test-match? redex-match?])
          term-match
          term-match/single
          redex-let
diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl
index b58013f333..6e41163950 100644
--- a/collects/redex/scribblings/ref.scrbl
+++ b/collects/redex/scribblings/ref.scrbl
@@ -344,6 +344,13 @@ matches, it returns a list of match structures describing the
 matches. If the match fails, the procedure returns @racket[#f].
 }
 
+@defform*[[(redex-match? lang @#,ttpattern any)
+           (redex-match? lang @#,ttpattern)]]{
+          
+Like @racket[redex-match], except it returns only a boolean
+indicating if the match was successful.
+}
+
 @defproc[(match? [val any/c]) boolean?]{
 
 Determines if a value is a @tt{match} structure.