suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve some errors from match and friends (close #1431, #1615) (#1974)

Browse Source 
* More specific error for no-clause match-lambda** (close #1615)

* Remove unused orig-stx parameter from racket/match internals

* Use of match-XYZ/derived for better errors (fix #1431)

* Tests for the exceptions produced by racket/match
This commit is contained in:
Milo 2018-04-25 17:17:39 -04:00 committed by Sam Tobin-Hochstadt
parent bc55560f8d
commit 026d368a38
5 changed files with 133 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test/tests/match/main.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base)
"match-tests.rkt" "other-plt-tests.rkt" "other-tests.rkt"
"match-tests.rkt" "match-exn-tests.rkt" "other-plt-tests.rkt" "other-tests.rkt"
"examples.rkt"
rackunit rackunit/text-ui)
@ -378,6 +378,7 @@
(run-tests (test-suite "Match Tests"
plt-match-tests
match-tests
match-exn-tests
new-tests
;; from bruce
other-tests

70
pkgs/racket-test/tests/match/match-exn-tests.rkt Normal file
View File

@ -0,0 +1,70 @@
(module match-tests mzscheme
(require mzlib/match rackunit)
(provide match-exn-tests)
(define simple-fail-tests
(test-suite
"Simple fall-through tests"
(test-case "No clauses"
(check-exn exn:misc:match?
(lambda () (match 3))))
(test-case "Fall-through with integer"
(check-exn exn:misc:match?
(lambda () (match 3
[2 'low]
[4 'high]))))
(test-case "Fall-through with #:when pattern"
(check-exn exn:misc:match?
(lambda () (match 3
[x #:when (> x 4) x]))))
(test-case "Failure procedure"
(check-exn exn:misc:match?
(lambda () (match 3
[3 (=> bye)
(bye)
's]
[2 ':o]))))))
(define exn-message-tests-1
(test-suite
"Exception messages for match-let-XYZ"
(test-case "match"
(check-exn #rx"match: no matching clause for 3"
(lambda () (match 3))))
(test-case "match*"
(check-exn #rx"match\\*: no matching clause for \\(3 4\\)"
(lambda () (match* [3 4]))))
(test-case "match-let"
(check-exn #rx"match-let: no matching clause for 3"
(lambda () (match-let ([2 3]) ':o))))
(test-case "match-let-values"
(check-exn #rx"match-let-values: no matching clause for \\(3 4\\)"
(lambda () (match-let-values ([(2 x) (values 3 4)]) ':o))))
(test-case "match-let*"
(check-exn #rx"match-let\\*: no matching clause for 3"
(lambda () (match-let* ([a 3] [2 a]) ':o))))
(test-case "match-let*-values"
(check-exn #rx"match-let\\*-values: no matching clause for \\(3 4\\)"
(lambda () (match-let*-values ([(a) 3] [(2 x) (values a 4)]) ':o))))))
(define exn-message-tests-2
(test-suite
"Exception messages other match forms"
(test-case "match-letrec"
(check-exn #rx"match-letrec: no matching clause for 3"
(lambda () (match-letrec ([a 3] [2 a]) ':o))))
(test-case "match-letrec-values"
(check-exn #rx"match-letrec-values: no matching clause for \\(3 5\\)"
(lambda () (match-letrec-values ([(a) 3] [(2 _) (values a 5)]) ':o))))
(test-case "match-define"
(check-exn #rx"match-define: no matching clause for \\(6 \\. 7\\)"
(lambda () (match-define (cons 3 x) '(6 . 7)) x)))
(test-case "match-define-values"
(check-exn #rx"match-define-values: no matching clause for \\(6 7\\)"
(lambda () (match-define-values (3 x) (values 6 7)) x)))))
(define match-exn-tests
(test-suite "Tests for exceptions raised by match.rkt"
simple-fail-tests
exn-message-tests-1
exn-message-tests-2)))

90
racket/collects/racket/match/define-forms.rkt
View File

@ -76,6 +76,8 @@
(define-syntax (match-lambda** stx)
(syntax-parse stx
[(_ (~and clauses [(pats ...) . rhs]) ...)
(when (null? (syntax-e #'(rhs ...)))
(raise-syntax-error #f "expected at least one clause to match-lambda**" stx))
(with-syntax* ([vars (generate-temporaries (car (syntax-e #'((pats ...) ...))))]
[body #`(match*/derived vars #,stx clauses ...)])
(syntax/loc stx (lambda vars body)))]))
@ -95,18 +97,25 @@
(match*/derived #,(append* idss) #,stx
[(patss ... ...) (let () body1 body ...)])))]))
(define-syntax (match-let*-values stx)
;; note: match-let*-values/derived is *not* provided
(define-syntax (match-let*-values/derived stx)
(syntax-parse stx
[(_ () body1 body ...)
[(_ orig-stx () body1 body ...)
(syntax/loc stx (let () body1 body ...))]
[(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
[(_ orig-stx ([(pats ...) rhs] rest-pats ...) body1 body ...)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
(quasisyntax/loc stx
(let-values ([(ids ...) rhs])
(match*/derived (ids ...) #,stx
(match*/derived (ids ...) orig-stx
[(pats ...) #,(syntax/loc stx
(match-let*-values (rest-pats ...)
body1 body ...))]))))]))
(match-let*-values/derived
orig-stx (rest-pats ...)
body1 body ...))]))))]))
(define-syntax (match-let*-values stx)
(syntax-parse stx
[(_ (~and cl ([(pats ...) rhs:expr] ...)) body1 body ...)
(quasisyntax/loc stx (match-let*-values/derived #,stx cl body1 body ...))]))
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
@ -122,50 +131,69 @@
(letrec ([nm (lambda vars loop-body)])
(nm init-exp ...))))]
[(_ ([pat init-exp:expr] ...) body1 body ...)
(syntax/loc stx (match-let-values ([(pat) init-exp] ...) body1 body ...))]))
(quasisyntax/loc stx
;; use of match*/derived instead of match-let-values fixes #1431
;; alternatively, we could have created let-values/derived but
;; that is not really necessary
(match*/derived [init-exp ...] #,stx [(pat ...) (let () body1 body ...)]))]))
(define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
(match-let*-values ([(pat) exp] ...) body1 body ...))
(define-syntax (match-let* stx)
(syntax-parse stx
[(_ ([pat rhs:expr] ...) body1 body ...)
(quasisyntax/loc stx
(match-let*-values/derived
#,stx
([(pat) rhs] ...)
body1 body ...))]))
;; note: match-define-values/derived is *not* provided
;; it may be useful enough to suggest we should provide it...
(define-syntax (match-define-values/derived stx)
(syntax-parse stx
[(_ orig-stx (pats ...) rhs:expr)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]
[(pb-ids ...) (pats->bound-vars parse-id (syntax->list #'(pats ...)))])
(quasisyntax/loc stx
(define-values (pb-ids ...)
(let-values ([(ids ...) rhs])
(match*/derived (ids ...) orig-stx
[(pats ...) (values pb-ids ...)])))))]))
(define-syntax (match-letrec stx)
(syntax-parse stx
[(_ ((~and cl [pat exp]) ...) body1 body ...)
(quasisyntax/loc stx
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[p (in-syntax #'(pat ...))]
[e (in-syntax #'(exp ...))])
(quasisyntax/loc c (match-define #,p #,e)))
body1 body ...))]))
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[p (in-syntax #'(pat ...))]
[e (in-syntax #'(exp ...))])
(quasisyntax/loc c
(match-define-values/derived #,stx (#,p) #,e)))
body1 body ...))]))
(define-syntax (match-letrec-values stx)
(syntax-parse stx
[(_ ((~and cl [(pat ...) exp]) ...) body1 body ...)
(quasisyntax/loc stx
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[p (in-syntax #'((pat ...) ...))]
[e (in-syntax #'(exp ...))])
(quasisyntax/loc c (match-define-values #,p #,e)))
body1 body ...))]))
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[ps (in-syntax #'((pat ...) ...))]
[e (in-syntax #'(exp ...))])
(quasisyntax/loc c
(match-define-values/derived #,stx #,ps #,e)))
body1 body ...))]))
(define-syntax (match-define stx)
(syntax-parse stx
[(_ pat rhs:expr)
(let ([p (parse-id #'pat)])
(with-syntax ([vars (bound-vars p)])
(quasisyntax/loc stx
(define-values vars (match*/derived (rhs) #,stx
[(pat) (values . vars)])))))]))
(quasisyntax/loc stx
(match-define-values/derived #,stx (pat) rhs))]))
(define-syntax (match-define-values stx)
(syntax-parse stx
[(_ (pats ...) rhs:expr)
(with-syntax ([(ids ...) (pats->bound-vars parse-id (syntax->list #'(pats ...)))])
(syntax/loc stx
(define-values (ids ...)
(match/values rhs
[(pats ...) (values ids ...)]))))]))
(quasisyntax/loc stx
(match-define-values/derived #,stx (pats ...) rhs))]))
(define-syntax (define/match stx)
(syntax-parse stx

5
racket/collects/racket/match/gen-match.rkt
View File

@ -24,9 +24,8 @@
(with-disappeared-uses
(syntax-parse clauses
[([pats . rhs] ...)
(parameterize ([orig-stx stx])
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)

2
racket/collects/racket/match/patterns.rkt
View File

@ -12,8 +12,6 @@
get-key
(struct-out Row)))
(define orig-stx (make-parameter #f))
(define-struct Pat () #:transparent)
;; v is an identifier
(define-struct (Var Pat) (v)