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

syntax/parse: fix spurious description for eh-alt-set

Browse Source 
closes #2551
This commit is contained in:
Ryan Culpepper 2019-03-26 16:47:52 +01:00
parent 076621558e
commit 22a9b0cf35
3 changed files with 22 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-test/tests/stxparse/test-exp.rkt
View File

@ -79,6 +79,18 @@
(s= ((x.c1 x.c2) ...) '((2 3) (4 5))))) (s= ((x.c1 x.c2) ...) '((2 3) (4 5)))))
(terx (#:c 1 2) ((~eh-var x extopts) ...) (terx (#:c 1 2) ((~eh-var x extopts) ...)
#rx"missing required occurrence of A option") #rx"missing required occurrence of A option")
;; from Alexis King (#2551) (3/2019)
(let ()
(define-eh-alternative-set opts
[pattern {~optional {~seq #:foo foo:expr}}])
(test-exn "eh-alts no spurious description"
(lambda (e)
(and (regexp-match? #rx"expected more terms" (exn-message e))
(not (regexp-match? #rx"eh-alt-parser" (exn-message e)))))
(lambda ()
(syntax-parse #'(use-opts #:foo)
[(_ {~eh-var o opts} ...) 'ok]))))
) )
(require 'eh-alts) (require 'eh-alts)

8
racket/collects/syntax/parse/private/parse.rkt
View File

@ -54,11 +54,11 @@
(let-values ([(name formals arity) (let-values ([(name formals arity)
(let ([p (check-stxclass-header #'header stx)]) (let ([p (check-stxclass-header #'header stx)])
(values (car p) (cadr p) (caddr p)))]) (values (car p) (cadr p) (caddr p)))])
(let ([the-rhs (parse-rhs #'rhss splicing? #:context stx)]) (let ([the-rhs (parse-rhs #'rhss splicing? #:context stx
#:default-description (symbol->string (syntax-e name)))])
(with-syntax ([name name] (with-syntax ([name name]
[formals formals] [formals formals]
[desc (cond [(rhs-description the-rhs) => constant-desc] [desc (cond [(rhs-description the-rhs) => constant-desc] [else #f])]
[else (symbol->string (syntax-e name))])]
[parser (generate-temporary (format-symbol "parse-~a" name))] [parser (generate-temporary (format-symbol "parse-~a" name))]
[arity arity] [arity arity]
[attrs (rhs-attrs the-rhs)] [attrs (rhs-attrs the-rhs)]
@ -155,7 +155,7 @@
(with-syntax ([formals* formals*] (with-syntax ([formals* formals*]
[(def ...) defs] [(def ...) defs]
[((vdef ...) ...) vdefss] [((vdef ...) ...) vdefss]
[description (or description (symbol->string (syntax-e name)))] [description description]
[transparent? transparent?] [transparent? transparent?]
[delimit-cut? delimit-cut?] [delimit-cut? delimit-cut?]
[body body]) [body body])

12
racket/collects/syntax/parse/private/rep.rkt
View File

@ -29,9 +29,9 @@
(-> syntax? (-> syntax?
boolean?)] boolean?)]
[parse-rhs [parse-rhs
(-> syntax? boolean? (->* [syntax? boolean? #:context (or/c false/c syntax?)]
#:context (or/c false/c syntax?) [#:default-description (or/c #f string?)]
rhs?)] rhs?)]
[parse-pattern+sides [parse-pattern+sides
(-> syntax? syntax? (-> syntax? syntax?
#:splicing? boolean? #:splicing? boolean?
@ -178,8 +178,8 @@
;; --- ;; ---
;; parse-rhs : Syntax Boolean #:context Syntax -> RHS ;; parse-rhs : Syntax Boolean #:context Syntax #:default-description (U String #f) -> RHS
(define (parse-rhs stx splicing? #:context ctx) (define (parse-rhs stx splicing? #:context ctx #:default-description [default-description #f])
(call/txlifts (call/txlifts
(lambda () (lambda ()
(parameterize ((current-syntax-context ctx)) (parameterize ((current-syntax-context ctx))
@ -194,7 +194,7 @@
(or attributes (or attributes
(filter (lambda (a) (symbol-interned? (attr-name a))) (filter (lambda (a) (symbol-interned? (attr-name a)))
(intersect-sattrss (map variant-attrs variants))))) (intersect-sattrss (map variant-attrs variants)))))
(make rhs sattrs transp? description variants (make rhs sattrs transp? (or description #`(quote #,default-description)) variants
(append (get-txlifts-as-definitions) defs) (append (get-txlifts-as-definitions) defs)
commit? delimit-cut?))))) commit? delimit-cut?)))))