diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index f0c232f..157ebe3 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/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) diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 6267cc7..9d44d36 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 all-...-follow-wildcards generate-literals) +(require "syntax-flatten.rkt" racket/list) +(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))] - [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)) + (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)) (test-case "wildcard-identifier?" - (check-true (wildcard-identifier? 'FOO)) - (check-true (wildcard-identifier? 'TOPPING)) + (check-true (wildcard-identifier? 'FOO)) + (check-true (wildcard-identifier? 'TOPPING)) - (check-false (wildcard-identifier? 'piZZa)) - (check-false (wildcard-identifier? 'please))) + (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-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 ...)))))) + (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 ...)))))) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 11189c9..9b08e5c 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ 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 ...))]) - #'(syntax-case STX-ARG (LITERAL ...) - [PAT . BODY] ... - [else . ELSEBODY]))] + [else . ELSEBODY]) #'(syntax-parse/easy STX-ARG (PAT ...) + [PAT . BODY] ... + [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-case STX0 (LITERAL ...) - [PAT0 (with-pattern (PAT+STX ...) (let () . BODY))] - [else (raise-syntax-error 'with-pattern - (format "unable to match pattern ~a" 'PAT0) STX0)]))]) + #'(syntax-parse/easy STX0 PAT0 + [PAT0 (with-pattern (PAT+STX ...) (let () . BODY))] + [else (raise-syntax-error 'with-pattern + (format "unable to match pattern ~a" 'PAT0) STX0)])]) (define-macro (format-string FMT ID0 ID ...)