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

syntax/parse: propagate description-if-constant to annotated pvars

Browse Source 
fixes #1392
This commit is contained in:
Ryan Culpepper 2016-07-31 18:13:09 -04:00
parent 71fbe4ad7d
commit d6a3a22989
6 changed files with 52 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -157,6 +157,16 @@
(a (~describe "thing" b))
#rx"expected more terms starting with thing$")
(let ()
(define-syntax-class B1 #:description "B1" (pattern _:id))
(define-syntax-class B2 (pattern _:id))
(terx (1)
(a b:B1)
#rx"expected more terms starting with B1")
(terx (1)
(a b:B2)
#rx"expected more terms starting with B2"))
;; Post:
(terx "hello"

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

@ -521,7 +521,7 @@ Conventions:
[#s(pat:svar name)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)]
[#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role)
[#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role _desc)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -691,7 +691,7 @@ Conventions:
[#s(pat:svar name)
#''(any)]
[#s(pat:var/p _ ...)
#'#f] ;; FIXME: need access to (constant) description as field
#`(quote #,(pat:var/p-desc (syntax-e #'p)))]
[#s(pat:datum d)
#''(datum d)]
[#s(pat:literal id _ip _lp)
@ -787,7 +787,7 @@ Conventions:
(parse:H x cx rest-x rest-cx rest-pr pattern pr* es*
(let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
k)))]
[#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role)
[#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role _desc)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)

33
racket/collects/syntax/parse/private/rep-data.rkt
View File

@ -35,11 +35,13 @@
delimit-cut? ;; Bool
) #:prefab)
#|
A Variant is
(make-variant stx (listof SAttr) Pattern (listof stx))
|#
(define-struct variant (ostx attrs pattern definitions) #:prefab)
;; A Variant is (variant Stx SAttrs Pattern Stxs)
(define-struct variant
(ostx ;; Stx
attrs ;; (Listof SAttr)
pattern ;; Pattern
definitions ;; (Listof Stx)
) #:prefab)
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
@ -54,12 +56,12 @@ DeclEnv =
(listof ConventionRule))
DeclEntry =
(den:lit id id ct-phase ct-phase)
(den:datum-lit id symbol)
(den:class id id Arguments)
(den:magic-class id id Arguments stx)
(den:parser id (listof SAttr) bool bool bool)
(den:delayed id id)
- (den:lit Id Id Stx Stx)
- (den:datum-lit Id Symbol)
- (den:class Id Id Arguments)
- (den:magic-class Id Id Arguments Stx)
- (den:parser Id (Listof SAttr) Bool Bool Bool String/#f)
- (den:delayed Id Id)
Arguments is defined in rep-patterns.rkt
@ -88,7 +90,7 @@ expressions are duplicated, and may be evaluated in different scopes.
(define-struct den:class (name class argu))
(define-struct den:magic-class (name class argu role))
(define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
(define-struct den:parser (parser attrs splicing? commit? delimit-cut? desc))
;; and from residual.rkt:
;; (define-struct den:lit (internal external input-phase lit-phase))
;; (define-struct den:datum-lit (internal external))
@ -133,7 +135,7 @@ expressions are duplicated, and may be evaluated in different scopes.
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(den:parser _p _a _sp _c _dc?)
[(den:parser _p _a _sp _c _dc? _desc)
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
@ -183,10 +185,6 @@ expressions are duplicated, and may be evaluated in different scopes.
(define DeclEntry/c
(or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?))
;; ct-phase = syntax, expr that computes absolute phase
;; usually = #'(syntax-local-phase-level)
(define ct-phase/c syntax?)
(provide (struct-out den:class)
(struct-out den:magic-class)
(struct-out den:parser)
@ -198,7 +196,6 @@ expressions are duplicated, and may be evaluated in different scopes.
(provide/contract
[DeclEnv/c contract?]
[DeclEntry/c contract?]
[ct-phase/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]
[stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]

14
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -13,8 +13,8 @@ Uses Arguments from kws.rkt
A SinglePattern is one of
(pat:any)
(pat:svar id) -- "simple" var, no stxclass
(pat:var/p id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser
(pat:literal identifier ct-phase ct-phase)
(pat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f) -- var with parser
(pat:literal identifier Stx Stx)
(pat:datum datum)
(pat:action ActionPattern SinglePattern)
(pat:head HeadPattern SinglePattern)
@ -44,7 +44,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:any () #:prefab)
(define-struct pat:svar (name) #:prefab)
(define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab)
(define-struct pat:literal (id input-phase lit-phase) #:prefab)
(define-struct pat:datum (datum) #:prefab)
(define-struct pat:action (action inner) #:prefab)
@ -91,7 +91,7 @@ A SideClause is just an ActionPattern
#|
A HeadPattern is one of
(hpat:var/p id id Arguments (listof IAttr) nat/#f bool stx)
(hpat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f)
(hpat:seq ListPattern)
(hpat:action ActionPattern HeadPattern)
(hpat:and HeadPattern SinglePattern)
@ -106,7 +106,7 @@ A HeadPattern is one of
(hpat:peek-not HeadPattern)
|#
(define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab)
(define-struct hpat:seq (inner) #:prefab)
(define-struct hpat:action (action inner) #:prefab)
(define-struct hpat:and (head single) #:prefab)
@ -214,7 +214,7 @@ A RepConstraint is one of
null]
[(pat:svar name)
(list (attr name 0 #t))]
[(pat:var/p name _ _ nested-attrs _ _ _)
[(pat:var/p name _ _ nested-attrs _ _ _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
@ -274,7 +274,7 @@ A RepConstraint is one of
(pattern-attrs sp)]
;; -- H patterns
[(hpat:var/p name _ _ nested-attrs _ _ _)
[(hpat:var/p name _ _ nested-attrs _ _ _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]

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

@ -283,7 +283,8 @@
(with-syntax ([parser (generate-temporary class)])
(values (make den:parser #'parser
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc) (stxclass-delimit-cut? sc))
(stxclass-commit? sc) (stxclass-delimit-cut? sc)
(stxclass-desc sc))
(list #`(define-values (parser)
(curried-stxclass-parser #,class #,argu)))))))]
[(regexp? name)
@ -294,7 +295,7 @@
(values (make den:delayed #'parser class)
(list #`(define-values (parser)
(curried-stxclass-parser #,class #,argu)))))])]
[(den:parser _p _a _sp _c _dc?)
[(den:parser _p _a _sp _c _dc? _desc)
(values entry null)]
[(den:delayed _p _c)
(values entry null)]))
@ -628,7 +629,7 @@
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)])
(list (create-ehpat
(hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f #f)
(eh-alternative-repc alt)
#f)
(replace-eh-alternative-attrs
@ -702,14 +703,14 @@
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(den:parser parser attrs splicing? commit? delimit-cut?)
[(den:parser parser attrs splicing? commit? delimit-cut? desc)
(check-no-delimit-cut-in-not id delimit-cut?)
(cond [splicing?
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id parser no-arguments attrs commit? "." #f)]
(parse-pat:id/h id parser no-arguments attrs commit? "." #f desc)]
[else
(parse-pat:id/s id parser no-arguments attrs commit? "." #f)])]
(parse-pat:id/s id parser no-arguments attrs commit? "." #f desc)])]
[(den:delayed parser class)
(let ([sc (get-stxclass class)])
(parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))]))
@ -767,7 +768,8 @@
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx
role)]
role
(stxclass-desc sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax stx "splicing syntax class not allowed here"))
@ -777,21 +779,22 @@
(stxclass-attrs sc)
(stxclass-commit? sc)
pfx
role)]))
role
(stxclass-desc sc))]))
(define (parse-pat:id/s name parser argu attrs commit? pfx role)
(define (parse-pat:id/s name parser argu attrs commit? pfx role desc)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc))
(define (parse-pat:id/s/integrate name predicate description role)
(define bind (name->bind name))
(pat:integrated bind predicate description role))
(define (parse-pat:id/h name parser argu attrs commit? pfx role)
(define (parse-pat:id/h name parser argu attrs commit? pfx role desc)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc))
(define (name->prefix id pfx)
(cond [(wildcard? id) #f]

4
racket/collects/syntax/parse/private/residual-ct.rkt
View File

@ -51,8 +51,8 @@ A ConventionRule is (list regexp DeclEntry)
A LiteralSet is
(make-literalset (listof LiteralSetEntry))
An LiteralSetEntry is one of
- (make-lse:lit symbol id ct-phase)
- (make-lse:datum-lit symbol symbol)
- (make-lse:lit Symbol Id Stx)
- (make-lse:datum-lit Symbol Symbol)
|#
(define-struct literalset (literals) #:transparent)
(define-struct lse:lit (internal external phase) #:transparent)