diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 05eca16..5b7e528 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -135,6 +135,14 @@ "no matching case for calling pattern" (syntax->datum stx))])) +(define-for-syntax (literalize-pat pat) + (cond + [(syntax->list pat) => (λ (subpats) (datum->syntax pat (map literalize-pat subpats)))] + [else (syntax-case pat () + [pat (and (identifier? #'pat) (literal-identifier-datum? (syntax->datum #'pat))) + #'(~literal pat)] + [pat #'pat])])) + (define-syntax (define-macro-cases stx) (define (error-source stx) (or (syntax-property stx 'caller) 'define-macro-cases)) (syntax-parse stx @@ -145,16 +153,13 @@ [(_ 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)]) + (with-syntax ([(PAT ...) (map literalize-pat (syntax->list #'(pat ...)))]) #'(define-macro id (λ (stx) (define result (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) (syntax-parse (syntax-case stx () [any #'any]) - #:literals BOUND-LITS - #:datum-literals UNBOUND-LITS - [pat . result-exprs] ... + [PAT . result-exprs] ... else-clause))) (if (syntax? result) result diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 7550d0c..0903869 100644 --- a/beautiful-racket-lib/br/private/generate-literals.rkt +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -1,8 +1,8 @@ #lang racket/base (require "syntax-flatten.rkt" racket/list racket/match) -(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals) +(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals literal-identifier-datum?) -(define (literal-identifier? pat-datum) +(define (literal-identifier-datum? pat-datum) (and (symbol? pat-datum) (not (memq pat-datum '(... _))) ; isn't a reserved identifier (let ([pat-str (symbol->string pat-datum)]) @@ -11,14 +11,14 @@ (define (wildcard? pat-datum) (and (symbol? pat-datum) - (not (literal-identifier? pat-datum)) + (not (literal-identifier-datum? 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)) + #:when (literal-identifier-datum? pat-datum)) pat-arg))