From 92a949c08e4297b08ab1c723eee59a0a6a9c7efa Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 25 Feb 2017 11:44:21 -0800
Subject: [PATCH] add `pattern-case` and `pattern-case-filter`

---
 beautiful-racket-lib/br/get-info.rkt |  4 +++-
 beautiful-racket-lib/br/syntax.rkt   | 22 ++++++++++++++++------
 2 files changed, 19 insertions(+), 7 deletions(-)

diff --git a/beautiful-racket-lib/br/get-info.rkt b/beautiful-racket-lib/br/get-info.rkt
index 8ff25a6..dec6c86 100644
--- a/beautiful-racket-lib/br/get-info.rkt
+++ b/beautiful-racket-lib/br/get-info.rkt
@@ -7,7 +7,9 @@
     (send t compute-racket-amount-to-indent pos (λ(x)
                                                   (case x
                                                     [("with-pattern"
-                                                      "with-shared-id") 'lambda]
+                                                      "with-shared-id"
+                                                      "pattern-case"
+                                                      "pattern-case-filter") 'lambda]
                                                     [("define-macro"
                                                       "define-macro-cases"
                                                       "define-cases") 'define]
diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt
index 2ec27de..671c493 100644
--- a/beautiful-racket-lib/br/syntax.rkt
+++ b/beautiful-racket-lib/br/syntax.rkt
@@ -25,19 +25,29 @@
 (module+ test
   (require rackunit))
 
+(define-macro (pattern-case-filter STX-ARG PAT+BODY ...)
+  #'(let* ([arg STX-ARG]
+           [stxs (or (and (syntax? arg) (syntax->list arg)) arg)])
+      (unless (and (list? stxs) (andmap syntax? stxs))
+        (raise-syntax-error 'pattern-case-filter
+                            (format "~v cannot be made into a list of syntax objects" (syntax->datum arg))))
+      (for*/list ([stx (in-list stxs)]
+                  [result (in-value (pattern-case stx PAT+BODY ... [else #f]))]
+                  #:when result)
+        result)))
 
-(define-macro-cases case-pattern
+(define-macro-cases pattern-case
   [(_ STX-ARG
       [PAT . BODY] ...
       [else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))])
                            #'(syntax-case STX-ARG (LITERAL ...)
                                [PAT . BODY] ...
                                [else . ELSEBODY]))]
-  [(_ STX-ARG
-      PAT+BODY ...) #'(case-pattern STX-ARG
-                                    PAT+BODY ...
-                                    [else (raise-syntax-error 'case-pattern
-                                                              (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
+  [(_ STX-ARG PAT+BODY ...)
+   #'(pattern-case STX-ARG
+                   PAT+BODY ...
+                   [else (raise-syntax-error 'pattern-case
+                                             (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
 
 (define-macro-cases with-pattern
   [(_ () . BODY) #'(begin . BODY)]