pull/13/merge
Matthew Butterick 7 years ago
parent 94e19b851e
commit f0ec809502

@ -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
@ -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))]))

@ -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 '(((((...))))))))))

Loading…
Cancel
Save