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

syntax/parse: use pattern for default min repc error

Browse Source 
see #1393

Also fix first-desc:* to only use constant descriptions.
This commit is contained in:
Ryan Culpepper 2016-08-01 09:30:05 -04:00
parent 9bf30e0977
commit 31fdac8773
2 changed files with 53 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -205,6 +205,18 @@
#rx"orange" #rx"orange"
#rx"banana") #rx"banana")
;; default for min rep constraint
(terx ()
(x:id ...+)
#rx"expected more terms starting with identifier")
(let ()
(define-syntax-class thing (pattern _))
(terx ()
(x:thing ...+)
#rx"expected more terms starting with thing"))
;; ---------------------------------------- ;; ----------------------------------------
;; See "Simplification" from syntax/parse/private/runtime-report ;; See "Simplification" from syntax/parse/private/runtime-report

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

@ -694,8 +694,8 @@ Conventions:
#''(datum d)] #''(datum d)]
[#s(pat:literal id _ip _lp) [#s(pat:literal id _ip _lp)
#''(literal id)] #''(literal id)]
[#s(pat:describe _p description _t? _role) [#s(pat:describe _p desc _t? _role)
#'description] ;; FIXME??? only constants? #`(quote #,(or (constant-desc #'desc) #'#f))]
[#s(pat:delimit pattern) [#s(pat:delimit pattern)
#'(first-desc:S pattern)] #'(first-desc:S pattern)]
[#s(pat:commit pattern) [#s(pat:commit pattern)
@ -708,6 +708,28 @@ Conventions:
#''description] #''description]
[_ #'#f])])) [_ #'#f])]))
;; (first-desc:H HeadPattern) : Expr
(define-syntax (first-desc:H stx)
(syntax-case stx ()
[(fdh hpat)
(syntax-case #'hpat ()
[#s(hpat:var/p _n _p _a _na _ac _c? _r desc) #'desc]
[#s(hpat:seq lp) #'(first-desc:L lp)]
[#s(hpat:describe _hp desc _t? _r)
#`(quote #,(or (constant-desc #'desc) #'#f))]
[#s(hpat:delimit hp) #'(first-desc:H hp)]
[#s(hpat:commit hp) #'(first-desc:H hp)]
[#s(hpat:ord hp _ _) #'(first-desc:H hp)]
[#s(hpat:post hp) #'(first-desc:H hp)]
[_ #'(first-desc:S hpat)])]))
(define-syntax (first-desc:L stx)
(syntax-case stx ()
[(fdl lpat)
(syntax-case #'lpat ()
[#s(pat:pair sp lp) #'(first-desc:S sp)]
[_ #'#f])]))
;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans] ;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct stx) (define-syntax (disjunct stx)
(syntax-case stx () (syntax-case stx ()
@ -933,6 +955,10 @@ Conventions:
(and repc (generate-temporary 'rep)))) (and repc (generate-temporary 'rep))))
(define rel-repcs (filter values repcs)) (define rel-repcs (filter values repcs))
(define rel-rep-ids (filter values rep-ids)) (define rel-rep-ids (filter values rep-ids))
(define rel-heads (for/list ([head (in-list (syntax->list #'(head ...)))]
[repc (in-list repcs)]
#:when repc)
head))
(define aattrs (define aattrs
(for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))] (for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))]
[repc (in-list repcs)] [repc (in-list repcs)]
@ -949,6 +975,7 @@ Conventions:
[(head-rep ...) rep-ids] [(head-rep ...) rep-ids]
[(rel-rep ...) rel-rep-ids] [(rel-rep ...) rel-rep-ids]
[(rel-repc ...) rel-repcs] [(rel-repc ...) rel-repcs]
[(rel-head ...) rel-heads]
[(a ...) attrs] [(a ...) attrs]
[(attr-repc ...) attr-repcs] [(attr-repc ...) attr-repcs]
[do-pair/null? [do-pair/null?
@ -967,7 +994,7 @@ Conventions:
alt-map head-rep head es loop-k) alt-map head-rep head es loop-k)
...) ...)
(cond [(< rel-rep (rep:min-number rel-repc)) (cond [(< rel-rep (rep:min-number rel-repc))
(let ([es (expectation-of-reps/too-few es rel-rep rel-repc)]) (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)])
(fail (failure loop-pr es)))] (fail (failure loop-pr es)))]
... ...
[else [else
@ -1065,12 +1092,18 @@ Conventions:
(define-syntax expectation-of-reps/too-few (define-syntax expectation-of-reps/too-few
(syntax-rules () (syntax-rules ()
[(_ es rep #s(rep:once name too-few-msg too-many-msg)) [(_ es rep #s(rep:once name too-few-msg too-many-msg) hpat)
(es-add-message (or too-few-msg (name->too-few/once name)) es)] (cond [(or too-few-msg (name->too-few/once name))
[(_ es rep #s(rep:optional name too-many-msg _)) => (lambda (msg) (es-add-message msg es))]
[(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))]
[else es])]
[(_ es rep #s(rep:optional name too-many-msg _) hpat)
(error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")] (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")]
[(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg)) [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg) hpat)
(es-add-message (or too-few-msg (name->too-few name)) es)])) (cond [(or too-few-msg (name->too-few name))
=> (lambda (msg) (es-add-message msg es))]
[(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))]
[else es])]))
(define-syntax expectation-of-reps/too-many (define-syntax expectation-of-reps/too-many
(syntax-rules () (syntax-rules ()