Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

match: nonlinear pat refs in list-no-order #4304

Open
wants to merge 13 commits into
base: master
Choose a base branch
from
Open

match: nonlinear pat refs in list-no-order #4304

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
13 commits
Select commit Hold shift + click to select a range
e969851
match: nonlinear pat refs in list-no-order
AlexKnauth Jun 16, 2022
fde8df6
match: ellipses nonlinear refs in list-no-order
AlexKnauth Jun 16, 2022
4f78aef
Add 'match-ellipsis-depth syntax property
AlexKnauth Jun 23, 2022
8186d56
match: order seen left-to-right
AlexKnauth Jun 23, 2022
b346559
match: fix depth of (list id ...) as id
AlexKnauth Jun 23, 2022
2d7bf74
match: test nonlinear pattern reference in id ...
AlexKnauth Jun 23, 2022
39fdefa
match: Error on non-linear decl with ... wrt ref
AlexKnauth Jun 27, 2022
b525ee5
match: Refactor bound-vars, orig/rename versions
AlexKnauth Jun 28, 2022
72e1f9c
match: nonlinear orig/non-renamed vars for seen
AlexKnauth Jun 29, 2022
ad8d1c4
match: test error on nonlinear pat decl with ...
AlexKnauth Jun 29, 2022
ef5bb0a
match: nonlinear pat decls zero depth wrt refs
AlexKnauth Jun 29, 2022
b6df3b3
match: document error on nonlinear pat decl in ...
AlexKnauth Jun 29, 2022
af4db44
match: test nonlinear ... error with non-null tail
AlexKnauth Jun 29, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
9 changes: 8 additions & 1 deletion pkgs/racket-doc/scribblings/reference/match.scrbl
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -94,13 +94,20 @@ In more detail, patterns match as follows:
@racket[_k]) @margin-note{Unlike in @racket[cond] and @racket[case],
@racket[else] is not a keyword in @racket[match].} or @racket[(var _id)]
--- matches anything, and binds @racket[_id] to the
matching values. If an @racket[_id] is used multiple times
matching values.

If an @racket[_id] is used multiple times
within a pattern, the corresponding matches must be the same
according to @racket[(match-equality-test)], except that
instances of an @racket[_id] in different @racketidfont{or} and
@racketidfont{not} sub-patterns are independent. The binding for @racket[_id] is
not available in other parts of the same pattern.

If @racket[_id] is used multiple times, but the first
use is in the scope of a @racketidfont{...} pattern
that doesn't encompass all uses, a syntax error is
raised.

@examples[
#:eval match-eval
(match '(1 2 3)
Expand Down
41 changes: 40 additions & 1 deletion pkgs/racket-test/tests/match/main.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
"legacy-match-tests.rkt"
"examples.rkt"
rackunit rackunit/text-ui
syntax/macro-testing
(only-in racket/base local-require))

(require mzlib/plt-match)
Expand Down Expand Up @@ -242,6 +243,20 @@
(check = 5 (match '((3) (3)) [(list a a) a] [_ 5]))))
(test-case "Nonlinear patterns use equal?"
(check equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5])))
(test-case "Nonlinear pattern reference in id ..."
(check-equal? (match '(1 1 1 1)
[(list x x ...) x])
1)
(check-false (match '(1 1 2 1)
[(list x x ...) x]
[_ #f]))
(check-false (match '(1 2 2 2)
[(list x x ...) x]
[_ #f])))
(test-case "Nonlinear patterns and list-no-order"
(check-equal? (match '(2 1 2 3)
[(cons a (list-no-order a rst ...)) (list a rst)])
'(2 (1 3))))
(test-case "Nonlinear patterns under ellipses"
(check-equal? (match '((1 1) (2 2) (3 3))
[(list (list a a) ...) a]
Expand All @@ -252,7 +267,31 @@
[_ #f]))
(check-equal? (match '((1 1 2 3) (2 1 2 3) (3 1 2 3))
[(list (cons a (list pre ... a post ...)) ...) (list a pre post)])
'((1 2 3) (() (1) (1 2)) ((2 3) (3) ()))))))
'((1 2 3) (() (1) (1 2)) ((2 3) (3) ())))
(check-equal? (match '((1 1 2 3) (2 1 2 3) (3 1 2 3))
[(list (cons a (list-no-order a rst ...)) ...) (list a rst)])
'((1 2 3) ((2 3) (1 3) (1 2)))))
(test-case "Invalid nonlinear pattern declarations under ellipses"
(check-exn #rx"^a: non-linear pattern used in `match` with ...$"
(lambda ()
(convert-syntax-error
(match '(1 2 3 4)
[(list a ... a) a]))))
(check-exn #rx"^a: non-linear pattern used in `match` with ...$"
(lambda ()
(convert-syntax-error
(match '((1 2 3) (1 2 3))
[(list (list a ...) a) a]))))
(check-exn #rx"^a: non-linear pattern used in `match` with ...$"
(lambda ()
(convert-syntax-error
(match '((1 2 3 4) (1 2 3))
[(list (list a ... _) a) a]))))
(check-exn #rx"^x: non-linear pattern used in `match` with ...$"
(lambda ()
(convert-syntax-error
(match '((1 2 3 4) (1 2 3 4))
[(list (list x ...) (list x ...)) x])))))))


(define doc-tests
Expand Down
135 changes: 83 additions & 52 deletions racket/collects/racket/match/compiler.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -198,7 +198,6 @@
(let ([transform
(lambda (row)
(define-values (p ps) (Row-split-pats row))
(define v (Var-v p))
(define seen (Row-vars-seen row))
;; a new row with the rest of the patterns
(cond
Expand All @@ -207,37 +206,29 @@
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))]
;; if we've seen this variable before, check that it's equal to
;; the one we saw
[(for/or ([e (in-list seen)])
(let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) (or id (list v v*)))))
=>
(lambda (id)
(if (identifier? id)
(make-Row ps
#`(if ((match-equality-test) #,x #,id)
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen)
(begin
(log-error "non-linear pattern used in `match` with ... at ~a and ~a"
(car id) (cadr id))
(let ([v* (free-identifier-mapping-get
(current-renaming) v (lambda () v))])
(make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(cons (cons v x) (Row-vars-seen row)))))))]
;; otherwise, bind the matched variable to x, and add it to the
;; list of vars we've seen
[else (let ([v* (free-identifier-mapping-get
(current-renaming) v (lambda () v))])
(make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(cons (cons v x) (Row-vars-seen row))))]))])
[else
(define v (Var-v p))
(define v*
(free-identifier-mapping-get
(current-renaming) v (lambda () v)))
(cond
;; if we've seen this variable before, check that it's equal to
;; the one we saw
[(find-seen v seen)
=>
(lambda (id)
(make-Row ps
#`(if #,(nonlinear-reference id x (get-depth v))
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen))]
;; otherwise, bind the matched variable to x, and add it to the
;; list of vars we've seen
[else (make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(append (Row-vars-seen row) (list (cons v x))))])]))])
;; compile the transformed block
(compile* xs (map transform block) esc))]
;; the Constructor rule
Expand All @@ -261,11 +252,13 @@
[qs (Or-ps (car pats))]
;; the variables bound by this pattern - they're the same for the
;; whole list
[vars
(for/list ([bv (bound-vars (car qs))]
[vars/orig
(for/list ([bv (bound-vars/orig (car qs))]
#:when (for/and ([seen-var seen])
(not (free-identifier=? bv (car seen-var)))))
bv)])
bv)]
[vars (rename-vars vars/orig)]
[pat-seen (map cons vars/orig vars/orig)])
(with-syntax ([(esc* success? var ...) (append (generate-temporaries '(esc* success?)) vars)])
;; do the or matching, and bind the results to the appropriate
;; variables
Expand All @@ -286,7 +279,7 @@
(list (make-Row (cdr pats)
(Row-rhs row)
(Row-unmatch row)
(append (map cons vars vars) seen)))
(append seen pat-seen)))
esc
#f)
(#,esc))))))]
Expand Down Expand Up @@ -378,6 +371,7 @@
[mutable? (GSeq-mutable? first)]
[make-Pair (if mutable? make-MPair make-Pair)]
[k (Row-rhs (car block))]
[prev-seen (Row-vars-seen (car block))]
[xvar (car (generate-temporaries (list #'x)))]
[complete-heads-pattern
(lambda (ps)
Expand All @@ -389,23 +383,31 @@
[heads
(for/list ([ps headss])
(complete-heads-pattern ps))]
[head-idss
[head-idss/orig
(for/list ([heads headss])
(apply append (map bound-vars heads)))]
(apply append (map bound-vars/orig heads)))]
[head-idss
(map rename-vars head-idss/orig)]
[head-idss/depth
(for/list ([head-ids head-idss] [once? onces?])
(if once? head-ids (map depth+1 head-ids)))]
[heads-seen
(map (lambda (x) (cons x #f))
(apply append (map bound-vars heads)))]
(for/list ([head heads] [once? onces?]
#:when #t
[v (bound-vars/orig head)])
(define v* (if once? v (depth+1 v)))
(if (zero? (get-depth v*)) (cons v* v*) (cons v* #f)))]
[tail-seen
(map (lambda (x) (cons x x))
(bound-vars tail))]
(bound-vars/orig tail))]
[hid-argss (map generate-temporaries head-idss)]
[head-idss* (map generate-temporaries head-idss)]
[head-idss* (map (generate-temporaries/seen prev-seen) head-idss/orig)]
[hid-args (apply append hid-argss)]
[reps (generate-temporaries (for/list ([head heads]) 'rep))])
(with-syntax ([x xvar]
[var0 (car vars)]
[((hid ...) ...) head-idss]
[((hid* ...) ...) head-idss*]
[((hid/depth ...) ...) head-idss/depth]
[((hid-arg ...) ...) hid-argss]
[(rep ...) reps]
[(maxrepconstraint ...)
Expand Down Expand Up @@ -433,22 +435,23 @@
[tail-rhs
#`(cond minrepclause ...
[else
(let ([hid hid-rhs] ... ...
(let ([hid/depth hid-rhs] ... ...
[fail-tail fail])
#,(compile*
(cdr vars)
(list (make-Row rest-pats k
(Row-unmatch (car block))
(append
prev-seen
heads-seen
tail-seen
(Row-vars-seen
(car block)))))
tail-seen)))
#'fail-tail))])])
(parameterize ([current-renaming
(for/fold ([ht (copy-mapping (current-renaming))])
([id (apply append head-idss)]
[id* (apply append head-idss*)])
([id (apply append head-idss/orig)]
[id* (apply append head-idss*)]
#:unless
(member id (map car prev-seen) free-identifier=?))
(free-identifier-mapping-put! ht id id*)
(free-identifier-mapping-for-each
ht
Expand All @@ -474,9 +477,8 @@
#`tail-rhs
(Row-unmatch (car block))
(append
heads-seen
(Row-vars-seen
(car block))))))
prev-seen
heads-seen))))
#'failkv))))))]
[else (error 'compile "unsupported pattern: ~a\n" first)]))

Expand Down Expand Up @@ -551,5 +553,34 @@
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))]))

;; find-seen : Id (Listof (Pairof Id (U #f Id))) -> (U #f Id)
(define (find-seen v seen)
(define e (assoc v seen bound-identifier=?))
(and
e
(let ([v* (car e)] [id (cdr e)])
(if (and (identifier? id) (zero? (get-depth v*)))
id
(raise-syntax-error #f
"non-linear pattern used in `match` with ..."
v v* (list v))))))

;; generate-temporaries/seen :
;; (Listof (Pairof Id (U #f Id))) -> (Listof Id) -> (Listof Id)
(define ((generate-temporaries/seen seen) vs)
(for/list ([v (in-list vs)])
(or (find-seen v seen) (generate-temporary v))))

;; nonlinear-reference : Identifier Identifier Natural -> Syntax
(define (nonlinear-reference decl ref ref-depth)
(cond
[(zero? ref-depth) #`((match-equality-test) #,ref #,decl)]
[else
(define good? #`(curryr (match-equality-test) #,decl))
(let loop ([depth ref-depth] [good? good?])
(cond
[(= 1 depth) #`(andmap #,good? #,ref)]
[else (loop (sub1 depth) #`(curry andmap #,good?))]))]))

;; (require mzlib/trace)
;; (trace compile* compile-one)
4 changes: 2 additions & 2 deletions racket/collects/racket/match/parse-helper.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -61,8 +61,8 @@
(or (Var? pat) (Dummy? pat)))
(make-OrderedAnd (list (make-Pred pred?)
(if to-list
(make-App to-list (list pat))
pat)))]
(make-App to-list (list (VarDummy-depth+1 pat)))
(VarDummy-depth+1 pat))))]
[else (make-GSeq (list (list pat))
(list min)
;; no upper bound
Expand Down