pair repair

pull/13/merge
Matthew Butterick 7 years ago
parent f0ec809502
commit 587f5ef946

@ -31,18 +31,19 @@
;; `syntax-parse` crabs if there are any duplicate ids, so remove them ;; `syntax-parse` crabs if there are any duplicate ids, so remove them
(map (λ (ids) (remove-duplicates ids bound-identifier=?)) (list bound-literals unbound-literals))) (map (λ (ids) (remove-duplicates ids bound-identifier=?)) (list bound-literals unbound-literals)))
(define (ellipses-follow-wildcards-or-subpatterns? pat) (define (ellipses-follow-wildcards-or-subpatterns? pat)
(define atom? (compose1 not pair?))
(let loop ([datum (syntax->datum pat)]) (let loop ([datum (syntax->datum pat)])
(or (atom? datum)
(and (andmap loop datum)
(cond (cond
[(null? datum) #t]
[(equal? datum '(...)) #f] [(equal? datum '(...)) #f]
[(<= 0 (length datum) 1)] [(list? datum) (and (andmap loop datum)
[else (for/and ([datum-left (in-list datum)] (for/and ([datum-left (in-list datum)]
[datum-right (in-list (cdr datum))] [datum-right (in-list (cdr datum))]
#:when (and (atom? datum-left) (eq? datum-right '...))) #:when (eq? datum-right '...))
(wildcard? datum-left))]))))) (or (wildcard? datum-left) (pair? datum-left))))]
[(pair? datum) (loop (flatten datum))]
[else #t])))
(module+ test (module+ test
@ -59,6 +60,7 @@
(test-case "all-...-follow-wildcards" (test-case "all-...-follow-wildcards"
(check-true (ellipses-follow-wildcards-or-subpatterns? #'())) (check-true (ellipses-follow-wildcards-or-subpatterns? #'()))
(check-true (ellipses-follow-wildcards-or-subpatterns? #'foo)) (check-true (ellipses-follow-wildcards-or-subpatterns? #'foo))
(check-true (ellipses-follow-wildcards-or-subpatterns? #'(foo . bar)))
(check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '(a b)))) (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 C ...))))
(check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((a b) ...)))) (check-true (ellipses-follow-wildcards-or-subpatterns? (datum->syntax #f '((a b) ...))))

Loading…
Cancel
Save