diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 396faf8..034e4bb 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/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-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 @@ -148,8 +152,8 @@ (define result (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) (syntax-parse (syntax-case stx () [any #'any]) - #:literals BOUND-LITS - #:datum-literals UNBOUND-LITS + #:literals BOUND-LITS + #:datum-literals UNBOUND-LITS [pat . result-exprs] ... else-clause))) (if (syntax? result) @@ -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))])) diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 40b3ea0..73a2017 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" 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,13 +9,17 @@ (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) (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]) @@ -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 '(((((...))))))))))