diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 1953ecd..f0c232f 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -141,6 +141,8 @@ [(_ 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))] [(_ 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 ...))]) #'(define-macro id (λ (stx) @@ -237,4 +239,4 @@ (define-macro (define-unhygienic-macro (ID PAT ...) BODY ... STX-OBJECT) #'(define-macro (ID PAT ...) BODY ... - (datum->syntax caller-stx (syntax->datum STX-OBJECT)))) \ No newline at end of file + (datum->syntax caller-stx (syntax->datum STX-OBJECT)))) diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 1819736..6267cc7 100644 --- a/beautiful-racket-lib/br/private/generate-literals.rkt +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -1,6 +1,6 @@ #lang racket/base (require "syntax-flatten.rkt") -(provide generate-literals) +(provide all-...-follow-wildcards generate-literals) (define (literal-identifier? pat-datum) (and (symbol? pat-datum) @@ -9,6 +9,11 @@ (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-identifier? 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) (for*/list ([pat-arg (in-list (syntax-flatten pats))] @@ -16,6 +21,34 @@ #:when (literal-identifier? pat-datum)) pat-arg)) +(define (all-...-follow-wildcards pats) + (define prev-datum (box #f)) + (and + (for*/and ([pat-arg (in-list (syntax-flatten pats))] + [pat-datum (in-value (syntax->datum pat-arg))]) + ;; OK if there's no previous datum, + (and + (when (eq? pat-datum '...) + (wildcard-identifier? (unbox prev-datum))) + (set-box! prev-datum pat-datum))) + #true)) + (module+ test (require rackunit) - (check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ (... ...) bar <=> 3Bar 3bar))) '(foo bar <=> 3Bar 3bar))) \ No newline at end of file + (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? 'TOPPING)) + + (check-false (wildcard-identifier? 'piZZa)) + (check-false (wildcard-identifier? 'please))) + + (test-case "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 C ...)))) + + (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 ... b ...))))))