use more `syntax-parse`

beautiful-racket-lib/br/define.rkt

@@ -97,6 +97,7 @@
 ;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
 (begin-for-syntax
   (require syntax/parse)
+  
   (define-syntax-class syntaxed-id
     #:literals (syntax quasisyntax)
     #:description "id in syntaxed form"
@@ -133,7 +134,6 @@
            "no matching case for calling pattern"
            (syntax->datum stx))]))
 
-
 (define-syntax (define-macro-cases stx)  
   (syntax-parse stx
     [(_ id:id)
@@ -143,12 +143,15 @@
     [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
      (unless (all-...-follow-wildcards #'(pat ...))
        (raise-syntax-error 'define-macro-cases "found ellipses after non-wildcard variable" (syntax->datum stx)))
-     (with-syntax ([(LITERAL ...) (generate-literals #'(pat ...))])
+     (with-syntax ([(BOUND-LITS UNBOUND-LITS)
+                    (generate-bound-and-unbound-literals #'(pat ...) #:treat-as-bound #'id)])
        #'(define-macro id
            (λ (stx)
              (define result
                (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
-                 (syntax-case stx (LITERAL ...)
+                 (syntax-parse (syntax-case stx () [any #'any])
+                     #:literals BOUND-LITS
+                     #:datum-literals UNBOUND-LITS
                    [pat . result-exprs] ...
                    else-clause)))
              (if (syntax? result)

beautiful-racket-lib/br/private/generate-literals.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require "syntax-flatten.rkt")
+(require "syntax-flatten.rkt" racket/list)
-(provide all-...-follow-wildcards generate-literals)
+(provide all-...-follow-wildcards generate-literals generate-bound-and-unbound-literals)
 
 (define (literal-identifier? pat-datum)
   (and (symbol? pat-datum)
@@ -19,36 +19,45 @@
   (for*/list ([pat-arg (in-list (syntax-flatten pats))]
               [pat-datum (in-value (syntax->datum pat-arg))]
               #:when (literal-identifier? pat-datum))
-    pat-arg))
+             pat-arg))
+
+(define (generate-bound-and-unbound-literals pats #:treat-as-bound [bound-id #f])
+  (define-values (bound-literals unbound-literals)
+    (partition identifier-binding (for/list ([pat (in-list (generate-literals pats))]
+                                             #:unless (and bound-id (bound-identifier=? pat bound-id)))
+                                            pat)))
+  ;; return as list of two lists so it's easy to match them in syntax pattern
+  (list (if bound-id (cons bound-id bound-literals) bound-literals)
+        unbound-literals))
 
 (define (all-...-follow-wildcards pats)
   (define prev-datum (box #f))
   (and
-    (for*/and ([pat-arg (in-list (syntax-flatten pats))]
+   (for*/and ([pat-arg (in-list (syntax-flatten pats))]
-               [pat-datum (in-value (syntax->datum pat-arg))])
+              [pat-datum (in-value (syntax->datum pat-arg))])
-      ;; OK if there's no previous datum,
+             ;; OK if there's no previous datum,
-      (and
+             (and
-        (when (eq? pat-datum '...)
+              (when (eq? pat-datum '...)
-          (wildcard-identifier? (unbox prev-datum)))
+                (wildcard-identifier? (unbox prev-datum)))
-        (set-box! prev-datum pat-datum)))
+              (set-box! prev-datum pat-datum)))
-    #true))
+   #true))
 
 (module+ test
   (require rackunit)
   (check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ (... ...) bar <=> 3Bar 3bar))) '(foo bar <=> 3Bar 3bar))
 
   (test-case "wildcard-identifier?"
-    (check-true (wildcard-identifier? 'FOO))
+             (check-true (wildcard-identifier? 'FOO))
-    (check-true (wildcard-identifier? 'TOPPING))
+             (check-true (wildcard-identifier? 'TOPPING))
 
-    (check-false (wildcard-identifier? 'piZZa))
+             (check-false (wildcard-identifier? 'piZZa))
-    (check-false (wildcard-identifier? 'please)))
+             (check-false (wildcard-identifier? 'please)))
 
   (test-case "all-...-follow-wildcards"
-    (check-true (all-...-follow-wildcards #'()))
+             (check-true (all-...-follow-wildcards #'()))
-    (check-true (all-...-follow-wildcards (datum->syntax #f '(a b))))
+             (check-true (all-...-follow-wildcards (datum->syntax #f '(a b))))
-    (check-true (all-...-follow-wildcards (datum->syntax #f '(a b C ...))))
+             (check-true (all-...-follow-wildcards (datum->syntax #f '(a b C ...))))
 
-    (check-false (all-...-follow-wildcards (datum->syntax #f '(...))))
+             (check-false (all-...-follow-wildcards (datum->syntax #f '(...))))
-    (check-false (all-...-follow-wildcards (datum->syntax #f '(a ...))))
+             (check-false (all-...-follow-wildcards (datum->syntax #f '(a ...))))
-    (check-false (all-...-follow-wildcards (datum->syntax #f '(A ... b ...))))))
+             (check-false (all-...-follow-wildcards (datum->syntax #f '(A ... b ...))))))

beautiful-racket-lib/br/syntax.rkt

@@ -8,6 +8,7 @@
          racket/format
          syntax/stx
          syntax/strip-context
+         syntax/parse
          br/define
          br/private/syntax-flatten)
 (provide (all-defined-out)
@@ -33,15 +34,22 @@
       (for*/list ([stx (in-list stxs)]
                   [result (in-value (pattern-case stx PAT+BODY ... [else #f]))]
                   #:when result)
-        result)))
+                 result)))
+
+
+(define-macro (syntax-parse/easy STX LITS . EXPS)
+  (with-syntax ([(BOUND-LITS UNBOUND-LITS) (generate-bound-and-unbound-literals #'LITS)])
+    #'(syntax-parse (syntax-case STX () [any #'any])
+        #:literals BOUND-LITS
+        #:datum-literals UNBOUND-LITS
+        . EXPS)))
 
 (define-macro-cases pattern-case
   [(_ STX-ARG
       [PAT . BODY] ...
-      [else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))])
+      [else . ELSEBODY]) #'(syntax-parse/easy STX-ARG (PAT ...)
-                           #'(syntax-case STX-ARG (LITERAL ...)
+                                              [PAT . BODY] ...
-                               [PAT . BODY] ...
+                                              [else . ELSEBODY])]
-                               [else . ELSEBODY]))]
   [(_ STX-ARG PAT+BODY ...)
    #'(pattern-case STX-ARG
                    PAT+BODY ...
@@ -51,11 +59,10 @@
 (define-macro-cases with-pattern
   [(_ () . BODY) #'(begin . BODY)]
   [(_ ([PAT0 STX0] PAT+STX ...) . BODY)
-   (with-syntax ([(LITERAL ...) (generate-literals #'PAT0)])
+   #'(syntax-parse/easy STX0 PAT0
-     #'(syntax-case STX0 (LITERAL ...)
+                        [PAT0 (with-pattern (PAT+STX ...) (let () . BODY))]
-         [PAT0 (with-pattern (PAT+STX ...) (let () . BODY))]
+                        [else (raise-syntax-error 'with-pattern
-         [else (raise-syntax-error 'with-pattern
+                                                  (format "unable to match pattern ~a" 'PAT0) STX0)])])
-                                   (format "unable to match pattern ~a" 'PAT0) STX0)]))])
 
 
 (define-macro (format-string FMT ID0 ID ...)