repair

beautiful-racket-lib/br/define.rkt

@@ -128,19 +128,23 @@
     [(_ id:id stxed-thing:syntaxed-thing) 
      #'(define-macro id (λ (stx) stxed-thing))]
     [(_ (id:id . patargs:expr) . body:expr)
-     #'(define-macro-cases id [(id . patargs) (begin . body)])]
+     (with-syntax ([id (syntax-property #'id 'caller 'define-macro)])
+       #'(define-macro-cases id [(id . patargs) (begin . body)]))]
     [else (raise-syntax-error
            'define-macro
            "no matching case for calling pattern"
            (syntax->datum stx))]))
 
 (define-syntax (define-macro-cases stx)
+  (define (error-source stx) (or (syntax-property stx 'caller) 'define-macro-cases))
   (syntax-parse stx
     [(_ id:id)
-     (raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
+     (raise-syntax-error (error-source #'id) "no cases given" (syntax->datum #'id))]
     [(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
-     (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
+     (raise-syntax-error (error-source #'id) "`else` clause must be last" (syntax->datum #'id))]
     [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
+     (unless (ellipses-follow-wildcards-or-subpatterns? #'(pat ...))
+       (raise-syntax-error (error-source #'id) "ellipsis in pattern can only appear after wildcard or subpattern" (syntax->datum stx)))
      (with-syntax ([(BOUND-LITS UNBOUND-LITS)
                     (generate-bound-and-unbound-literals #'(pat ...) #:treat-as-bound #'id)])
        #'(define-macro id
@@ -163,7 +167,7 @@
                 "no matching case for calling pattern"
                 (syntax->datum caller-stx))])]
     [else (raise-syntax-error
-           'define-macro-cases
+           (error-source #'id)
            "no matching case for calling pattern"
            (syntax->datum stx))]))
 

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

@@ -1,6 +1,6 @@
 #lang racket/base
 (require "syntax-flatten.rkt" racket/list)
-(provide generate-literals generate-bound-and-unbound-literals)
+(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals)
 
 (define (literal-identifier? pat-datum)
   (and (symbol? pat-datum)
@@ -9,6 +9,10 @@
          (or (not (regexp-match #rx"[A-Z]" pat-str)) ; either doesn't contain at least one uppercase letter ...
              (not (equal? (string-upcase pat-str) pat-str)))))) ;...  or doesn't contain all uppercase letters
 
+(define (wildcard? pat-datum)
+  (and (symbol? pat-datum)
+       (not (literal-identifier? pat-datum))
+       (not (memq pat-datum '(... _)))))
 
 ;; generate literals for any symbols that are not ... or _ and not IN_CAPS
 (define (generate-literals pats)
@@ -27,4 +31,47 @@
   ;; `syntax-parse` crabs if there are any duplicate ids, so remove them
   (map (λ (ids) (remove-duplicates ids bound-identifier=?)) (list bound-literals unbound-literals)))
 
+(define (ellipses-follow-wildcards-or-subpatterns? pat)
+  (define atom? (compose1 not pair?))
+  (let loop ([datum (syntax->datum pat)])
+    (or (atom? datum)
+        (and (andmap loop datum)
+             (cond
+               [(equal? datum '(...)) #f]
+               [(<= 0 (length datum) 1)]
+               [else (for/and ([datum-left (in-list datum)]
+                               [datum-right (in-list (cdr datum))]
+                               #:when (and (atom? datum-left) (eq? datum-right '...)))
+                       (wildcard? datum-left))])))))
+
+
+(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? 'FOO))
+             (check-true (wildcard? 'TOPPING))
+
+             (check-false (wildcard? 'piZZa))
+             (check-false (wildcard? 'please)))
+
+  (test-case "all-...-follow-wildcards"
+             (check-true (ellipses-follow-wildcards-or-subpatterns? #'()))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? #'foo))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(a b))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(a b C ...))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((a b) ...))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((C D) ...))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((C ...) ...))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(((C ...) ...) ...))))
+             (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(((C ...) D ...) ...))))
 
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(a ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(A ... b ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((a ...) ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(((a ...) ...) ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(((B ...) a ...) ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((...) B ...))))
+             (check-false (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(((((...))))))))))