From fb7c7e37938ee6cdaa6cd8d5f9aee9e939592226 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 29 Feb 2012 05:52:48 -0700 Subject: [PATCH] syntax/parse: added roles, other updates/fixes expr/c uses role for contract label when avail export ~peek-not (previously missed) fixes for integrable stxclasses --- collects/syntax/parse/debug.rkt | 2 +- .../syntax/parse/experimental/contract.rkt | 11 +- .../syntax/parse/experimental/provide.rkt | 2 +- .../syntax/parse/experimental/specialize.rkt | 4 +- .../syntax/parse/experimental/splicing.rkt | 4 +- collects/syntax/parse/private/keywords.rkt | 1 + collects/syntax/parse/private/parse.rkt | 97 ++++++----- collects/syntax/parse/private/rep-data.rkt | 23 ++- .../syntax/parse/private/rep-patterns.rkt | 40 ++--- collects/syntax/parse/private/rep.rkt | 162 +++++++++--------- collects/syntax/parse/private/residual.rkt | 15 +- .../syntax/parse/private/runtime-progress.rkt | 4 +- .../syntax/parse/private/runtime-reflect.rkt | 4 +- .../syntax/parse/private/runtime-report.rkt | 18 +- collects/syntax/parse/private/runtime.rkt | 4 +- .../syntax/scribblings/parse/litconv.scrbl | 4 +- .../syntax/scribblings/parse/patterns.scrbl | 78 ++++++--- .../syntax/scribblings/parse/stxclasses.scrbl | 27 +-- collects/tests/stxparse/select.rkt | 31 ++++ 19 files changed, 315 insertions(+), 216 deletions(-) diff --git a/collects/syntax/parse/debug.rkt b/collects/syntax/parse/debug.rkt index f5b90c5855..5b556bffc4 100644 --- a/collects/syntax/parse/debug.rkt +++ b/collects/syntax/parse/debug.rkt @@ -39,7 +39,7 @@ [(name ...) (map attr-name attrs)] [(depth ...) (map attr-depth attrs)]) #'(let ([fh (lambda (fs) fs)]) - (app-argu parser x x (ps-empty x x) null fh fh + (app-argu parser x x (ps-empty x x) null fh fh #f (lambda (fh . attr-values) (map vector '(name ...) '(depth ...) attr-values)) argu)))))])) diff --git a/collects/syntax/parse/experimental/contract.rkt b/collects/syntax/parse/experimental/contract.rkt index c0f14a6ebe..51f85d3ad0 100644 --- a/collects/syntax/parse/experimental/contract.rkt +++ b/collects/syntax/parse/experimental/contract.rkt @@ -4,14 +4,17 @@ "provide.rkt" unstable/wrapc (only-in syntax/parse/private/residual ;; keep abs. path - this-context-syntax) + this-context-syntax + this-role) racket/contract/base) +(define not-given (gensym)) + (define-syntax-class (expr/c ctc-stx #:positive [pos-blame 'use-site] #:negative [neg-blame 'from-macro] #:macro [macro-name #f] - #:name [expr-name #f] + #:name [expr-name not-given] #:context [ctx #f]) #:attributes (c) (pattern y:expr @@ -20,7 +23,9 @@ #'y #:positive pos-blame #:negative neg-blame - #:name expr-name + #:name (if (eq? expr-name not-given) + this-role + expr-name) #:macro macro-name #:context (or ctx (this-context-syntax))))) diff --git a/collects/syntax/parse/experimental/provide.rkt b/collects/syntax/parse/experimental/provide.rkt index b230d70b70..76d612cd93 100644 --- a/collects/syntax/parse/experimental/provide.rkt +++ b/collects/syntax/parse/experimental/provide.rkt @@ -85,7 +85,7 @@ [opc-id opc] ... [okwc-id okwc] ...) (rename-contract - (->* (any/c any/c any/c any/c any/c any/c any/c + (->* (any/c any/c any/c any/c any/c any/c any/c any/c mpc-id ... mkw-c-part ... ...) (okw-c-part ... ...) any) diff --git a/collects/syntax/parse/experimental/specialize.rkt b/collects/syntax/parse/experimental/specialize.rkt index 057b6225a8..3c586ebfd8 100644 --- a/collects/syntax/parse/experimental/specialize.rkt +++ b/collects/syntax/parse/experimental/specialize.rkt @@ -35,5 +35,5 @@ options #f)) (define-values (parser) - (lambda (x cx pr es fh0 cp0 success . formals) - (app-argu target-parser x cx pr es fh0 cp0 success argu)))))))])) + (lambda (x cx pr es fh0 cp0 rl success . formals) + (app-argu target-parser x cx pr es fh0 cp0 rl success argu)))))))])) diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt index d73986267a..64a5e63ec6 100644 --- a/collects/syntax/parse/experimental/splicing.rkt +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -34,7 +34,7 @@ description) (define parser (let ([permute (mk-permute '(a.name ...))]) - (lambda (x cx pr es fh _cp success param ...) + (lambda (x cx pr es fh _cp rl success param ...) (let ([stx (datum->syntax cx x cx)]) (let ([result (let/ec escape @@ -50,7 +50,7 @@ ((error) (let ([es (list* (expect:message (cadr result)) - (expect:thing (get-description param ...) #f) + (expect:thing (get-description param ...) #f rl) es)]) (fh (failure pr es)))))))))) (define-syntax name diff --git a/collects/syntax/parse/private/keywords.rkt b/collects/syntax/parse/private/keywords.rkt index d37c9dfa59..fb52ebc7aa 100644 --- a/collects/syntax/parse/private/keywords.rkt +++ b/collects/syntax/parse/private/keywords.rkt @@ -37,3 +37,4 @@ (define-keyword ~post) (define-keyword ~eh-var) (define-keyword ~peek) +(define-keyword ~peek-not) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 783ab157ad..eb7967a943 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -73,10 +73,10 @@ #f '#s(options #t #t) (integrate (quote-syntax predicate) 'description))) - (define (parser x cx pr es fh0 cp0 success) + (define (parser x cx pr es fh0 cp0 rl success) (if (predicate x) (success fh0) - (let ([es (cons (expect:thing 'description #t) es)]) + (let ([es (cons (expect:thing 'description #t rl) es)]) (fh0 (failure pr es)))))))])) (define-syntax (parser/rhs stx) @@ -163,39 +163,43 @@ ;; ============================================================ #| -Parsing protocol: +Parsing protocols: -(parse:* <*> * progress-var expectstack-var success-expr) : Ans +(parse: pr es success-expr) : Ans -*-stxclass-parser - : stxish stx progress expectstack fail-handler cut-prompt success-proc arg ... -> Ans + : x cx + : x cx rest-x rest-cx rest-pr + : x cx ??? + : x cx - : x cx - : x cx rest-x rest-cx rest-pr - : x cx ??? - : x cx + x is term to parse, usually syntax but can be pair/null (stx-list?) in cdr patterns + cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src + pr, es are progress and expectstack, respectively + rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr -x is term to parse, usually syntax but can be pair, empty in cdr patterns -cx is most recent syntax object: - if x must be coerced to syntax, use cx as lexctx and src +(stxclass-parser x cx pr es fail-handler cut-prompt role success-proc arg ...) : Ans -success-proc : fail-handler attr-value ... -> Ans + success-proc: + for stxclass, is (fail-handler attr-value ... -> Ans) + for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans) + fail-handler, cut-prompt : failure -> Ans -Usually sub-patterns processed in tail position, -but *can* do non-tail calls for: +Fail-handler is normally represented with stxparam 'fail-handler', but must be +threaded through stxclass calls (in through stxclass-parser, out through +success-proc) to support backtracking. Cut-prompt is never changed within +stxclass or within alternative, so no threading needed. + +Usually sub-patterns processed in tail position, but *can* do non-tail calls for: - ~commit - var of stxclass with ~commit -(Also safe to keep normal tail-call protocol.) +It is also safe to keep normal tail-call protocol and just adjust fail-handler. There is no real benefit to specializing ~commit, since it does not involve creating a success closure. -|# - -#| -Optimizations +Some optimizations: - commit protocol for stxclasses (but not ~commit, no point) - - avoid choice point in (EH ... . ()) by eager pair check - - integrable stxclasses (identifier, keyword, expr) + - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check + - integrable stxclasses, specialize ellipses of integrable stxclasses |# ;; ---- @@ -237,7 +241,7 @@ Conventions: - success : var (bound to success procedure) - k : expr - rest-x, rest-cx, rest-pr : id (to be bound) - - fh, cp : id (var) + - fh, cp, rl : id (var) |# ;; (parse:rhs rhs relsattrs (arg:id ...) get-description:id splicing?) @@ -248,14 +252,15 @@ Conventions: [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) #s(options commit? delimit-cut?) _integrate) relsattrs formals splicing? description) - #'(lambda (x cx pr es fh0 cp0 success . formals) + #'(lambda (x cx pr es fh0 cp0 rl success . formals) def ... (#%expression - (with ([this-syntax x]) + (with ([this-syntax x] + [this-role rl]) (syntax-parameterize ((this-context-syntax (syntax-rules () [(tbs) (ps-context-syntax pr)]))) - (let ([es (cons (expect:thing description 'transparent?) es)] + (let ([es (cons (expect:thing description 'transparent? rl) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (with ([fail-handler fh0] [cut-prompt cp0]) @@ -416,10 +421,10 @@ Conventions: k)] [#s(pat:any _attrs) #'k] - [#s(pat:var _attrs name #f _ () _ _) + [#s(pat:var _attrs name #f _ () _ _ _) #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) k)] - [#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit?) + [#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit? role) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) @@ -427,7 +432,7 @@ Conventions: #'())]) (if (not (syntax-e #'commit?)) ;; The normal protocol - #'(app-argu parser x cx pr es fail-handler cut-prompt + #'(app-argu parser x cx pr es fail-handler cut-prompt role (lambda (fh av ...) (let-attributes (name-attr ...) (let-attributes* ((nested-a ...) (av ...)) @@ -439,7 +444,7 @@ Conventions: #'(let-values ([(fs av ...) (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))]) (with ([cut-prompt fail-handler]) - (app-argu parser x cx pr es fail-handler cut-prompt + (app-argu parser x cx pr es fail-handler cut-prompt role (lambda (fh av ...) (values #f av ...)) argu)))]) (if fs @@ -454,7 +459,7 @@ Conventions: #'())]) (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) - (app-argu parser x cx pr es fail-handler cut-prompt + (app-argu parser x cx pr es fail-handler cut-prompt #f (lambda (fh . result) (let-attributes (name-attr ...) (let/unpack ((nested-a ...) result) @@ -543,8 +548,8 @@ Conventions: [pr (ps-add-unpstruct pr)]) (parse:S datum scx subpattern pr es k)) (fail (failure pr es))))] - [#s(pat:describe attrs description transparent? pattern) - #`(let ([es (cons (expect:thing description transparent?) es)] + [#s(pat:describe attrs pattern description transparent? role) + #`(let ([es (cons (expect:thing description transparent? role) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (parse:S x cx pattern pr es k))] [#s(pat:delimit attrs pattern) @@ -562,7 +567,7 @@ Conventions: [#s(pat:post attrs pattern) #`(let ([pr (ps-add-post pr)]) (parse:S x cx pattern pr es k))] - [#s(pat:integrated _attrs name predicate description) + [#s(pat:integrated _attrs name predicate description role) (with-syntax ([(name-attr ...) (if (identifier? #'name) #'([#s(attr name 0 #t) x*]) @@ -570,7 +575,7 @@ Conventions: #'(let ([x* (datum->syntax cx x cx)]) (if (predicate x*) (let-attributes (name-attr ...) k) - (let ([es (cons (expect:thing 'description #t) es)]) + (let ([es (cons (expect:thing 'description #t role) es)]) (fail (failure pr es))))))])])) ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] @@ -663,13 +668,13 @@ Conventions: (syntax-case stx () [(parse:H x cx rest-x rest-cx rest-pr head pr es k) (syntax-case #'head () - [#s(hpat:describe _ description transparent? pattern) - #`(let ([es* (cons (expect:thing description transparent?) es)] + [#s(hpat:describe _ pattern description transparent? role) + #`(let ([es* (cons (expect:thing description transparent? role) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (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 _attrs name parser argu (nested-a ...) attr-count commit?) + [#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit? role) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) @@ -678,7 +683,7 @@ Conventions: #'())]) (if (not (syntax-e #'commit?)) ;; The normal protocol - #`(app-argu parser x cx pr es fail-handler cut-prompt + #`(app-argu parser x cx pr es fail-handler cut-prompt role (lambda (fh rest-x rest-cx rest-pr av ...) (let-attributes (name-attr ...) (let-attributes* ((nested-a ...) (av ...)) @@ -690,7 +695,7 @@ Conventions: #'(let-values ([(fs rest-x rest-cx rest-pr av ...) (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))]) (with ([cut-prompt fail-handler]) - (app-argu parser x cx pr es fail-handler cut-prompt + (app-argu parser x cx pr es fail-handler cut-prompt role (lambda (fh rest-x rest-cx rest-pr av ...) (values #f rest-x rest-cx rest-pr av ...)) argu)))]) @@ -707,7 +712,7 @@ Conventions: #'())]) (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) - (app-argu parser x cx pr es fail-handler cut-prompt + (app-argu parser x cx pr es fail-handler cut-prompt #f (lambda (fh rest-x rest-cx rest-pr . result) (let-attributes (name-attr ...) (let/unpack ((nested-a ...) result) @@ -803,19 +808,19 @@ Conventions: ;; == Specialized cases ;; -- (x ... . ()) [(parse:dots x cx (#s(ehpat (attr0) - #s(pat:var _attrs name #f _ () _ _) + #s(pat:var _attrs name #f _ () _ _ _) #f)) #s(pat:datum () ()) pr es k) - #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f)]) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) (case status ((ok) (let-attributes ([attr0 result]) k)) (else (fail result))))] ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr [(parse:dots x cx (#s(ehpat (attr0) - #s(pat:integrated _attrs _name pred? desc) + #s(pat:integrated _attrs _name pred? desc role) #f)) #s(pat:datum () ()) pr es k) - #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc)]) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) (case status ((ok) (let-attributes ([attr0 result]) k)) (else (fail result))))] diff --git a/collects/syntax/parse/private/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt index 08736cd6f6..489692f1e3 100644 --- a/collects/syntax/parse/private/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -72,12 +72,23 @@ DeclEnv = DeclEntry = (den:lit id id ct-phase ct-phase) (den:class id id Arguments) - (den:magic-class id id Arguments) + (den:magic-class id id Arguments stx) (den:parser id (listof SAttr) bool bool bool) (den:delayed id id) Arguments is defined in rep-patterns.rkt +A DeclEnv is built up in stages: + 1) syntax-parse (or define-syntax-class) directives + #:literals -> den:lit + #:local-conventions -> den:class + #:conventions -> den:delayed + #:literal-sets -> den:lit + 2) pattern directives + #:declare -> den:magic-class + 3) create-aux-def creates aux parser defs + den:class -> den:parser or den:delayed + == Scoping == A #:declare directive results in a den:magic-class entry, which @@ -91,7 +102,7 @@ expressions are duplicated, and may be evaluated in different scopes. (define-struct den:lit (internal external input-phase lit-phase)) (define-struct den:class (name class argu)) -(define-struct den:magic-class (name class argu)) +(define-struct den:magic-class (name class argu role)) (define-struct den:parser (parser attrs splicing? commit? delimit-cut?)) ;; and from residual.rkt: (define-struct den:delayed (parser class)) @@ -117,7 +128,7 @@ expressions are duplicated, and may be evaluated in different scopes. (match val [(struct den:lit (_i _e _ip _lp)) (wrong-syntax id "identifier previously declared as literal")] - [(struct den:magic-class (name _c _a)) + [(struct den:magic-class (name _c _a _r)) (if (and blame-declare? stxclass-name) (wrong-syntax name "identifier previously declared with syntax class ~a" @@ -135,11 +146,11 @@ expressions are duplicated, and may be evaluated in different scopes. (wrong-syntax id "(internal error) late unbound check")] ['#f (void)]))) -(define (declenv-put-stxclass env id stxclass-name argu) +(define (declenv-put-stxclass env id stxclass-name argu [role #f]) (declenv-check-unbound env id) (make-declenv (bound-id-table-set (declenv-table env) id - (make den:magic-class id stxclass-name argu)) + (make den:magic-class id stxclass-name argu role)) (declenv-conventions env))) ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a @@ -212,7 +223,7 @@ expressions are duplicated, and may be evaluated in different scopes. [declenv-lookup (-> DeclEnv/c identifier? any)] [declenv-put-stxclass - (-> DeclEnv/c identifier? identifier? arguments? + (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f) DeclEnv/c)] [declenv-domain-difference (-> DeclEnv/c (listof identifier?) diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt index 1cff8382b6..0db64f339c 100644 --- a/collects/syntax/parse/private/rep-patterns.rkt +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -22,7 +22,7 @@ A Base is (listof IAttr) #| A SinglePattern is one of (pat:any Base) - (pat:var Base id id Arguments (listof IAttr) nat/#f bool) + (pat:var Base id id Arguments (listof IAttr) nat/#f bool stx) (pat:literal Base identifier ct-phase ct-phase) (pat:datum Base datum) (pat:action Base ActionPattern SinglePattern) @@ -35,12 +35,12 @@ A SinglePattern is one of (pat:vector Base SinglePattern) (pat:box Base SinglePattern) (pat:pstruct Base key SinglePattern) - (pat:describe Base stx boolean SinglePattern) + (pat:describe Base SinglePattern stx boolean stx) (pat:delimit Base SinglePattern) (pat:commit Base SinglePattern) (pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) (pat:post Base SinglePattern) - (pat:integrated Base id/#f id string) + (pat:integrated Base id/#f id string stx) A ListPattern is a subtype of SinglePattern; one of (pat:datum Base '()) @@ -51,7 +51,7 @@ A ListPattern is a subtype of SinglePattern; one of |# (define-struct pat:any (attrs) #:prefab) -(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab) +(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct pat:literal (attrs id input-phase lit-phase) #:prefab) (define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:action (attrs action inner) #:prefab) @@ -64,12 +64,12 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:vector (attrs pattern) #:prefab) (define-struct pat:box (attrs pattern) #:prefab) (define-struct pat:pstruct (attrs key pattern) #:prefab) -(define-struct pat:describe (attrs description transparent? pattern) #:prefab) +(define-struct pat:describe (attrs pattern description transparent? role) #:prefab) (define-struct pat:delimit (attrs pattern) #:prefab) (define-struct pat:commit (attrs pattern) #:prefab) (define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) (define-struct pat:post (attrs pattern) #:prefab) -(define-struct pat:integrated (attrs name predicate description) #:prefab) +(define-struct pat:integrated (attrs name predicate description role) #:prefab) #| A ActionPattern is one of @@ -94,13 +94,13 @@ action:and is desugared below in create-* procedures #| A HeadPattern is one of - (hpat:var Base id id Arguments (listof IAttr) nat/#f bool) + (hpat:var Base id id Arguments (listof IAttr) nat/#f bool stx) (hpat:seq Base ListPattern) (hpat:action Base ActionPattern HeadPattern) (hpat:and Base HeadPattern SinglePattern) (hpat:or Base (listof HeadPattern)) (hpat:optional Base HeadPattern (listof clause:attr)) - (hpat:describe Base stx/#f boolean HeadPattern) + (hpat:describe Base HeadPattern stx/#f boolean stx) (hpat:delimit Base HeadPattern) (hpat:commit Base HeadPattern) (hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) @@ -109,13 +109,13 @@ A HeadPattern is one of (hpat:peek-not Base HeadPattern) |# -(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab) +(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:action (attrs action inner) #:prefab) (define-struct hpat:and (attrs head single) #:prefab) (define-struct hpat:or (attrs patterns) #:prefab) (define-struct hpat:optional (attrs inner defaults) #:prefab) -(define-struct hpat:describe (attrs description transparent? pattern) #:prefab) +(define-struct hpat:describe (attrs pattern description transparent? role) #:prefab) (define-struct hpat:delimit (attrs pattern) #:prefab) (define-struct hpat:commit (attrs pattern) #:prefab) (define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) @@ -239,10 +239,10 @@ A SideClause is one of (define (create-pat:any) (make pat:any null)) -(define (create-pat:var name parser argu nested-attrs attr-count commit?) +(define (create-pat:var name parser argu nested-attrs attr-count commit? role) (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make pat:var attrs name parser argu nested-attrs attr-count commit?))) + (make pat:var attrs name parser argu nested-attrs attr-count commit? role))) (define (create-pat:reflect obj argu attr-decls name nested-attrs) (let ([attrs @@ -279,8 +279,8 @@ A SideClause is one of (define (create-pat:pstruct key pattern) (make pat:pstruct (pattern-attrs pattern) key pattern)) -(define (create-pat:describe description transparent? p) - (make pat:describe (pattern-attrs p) description transparent? p)) +(define (create-pat:describe p description transparent? role) + (make pat:describe (pattern-attrs p) p description transparent? role)) (define (create-pat:and patterns) (let ([attrs (append-iattrs (map pattern-attrs patterns))]) @@ -306,9 +306,9 @@ A SideClause is one of (define (create-pat:post pattern) (make pat:post (pattern-attrs pattern) pattern)) -(define (create-pat:integrated name predicate description) +(define (create-pat:integrated name predicate description role) (let ([attrs (if name (list (make attr name 0 #t)) null)]) - (make pat:integrated attrs name predicate description))) + (make pat:integrated attrs name predicate description role))) ;; ---- @@ -336,10 +336,10 @@ A SideClause is one of ;; ---- -(define (create-hpat:var name parser argu nested-attrs attr-count commit?) +(define (create-hpat:var name parser argu nested-attrs attr-count commit? role) (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make hpat:var attrs name parser argu nested-attrs attr-count commit?))) + (make hpat:var attrs name parser argu nested-attrs attr-count commit? role))) (define (create-hpat:reflect obj argu attr-decls name nested-attrs) (let ([attrs @@ -357,8 +357,8 @@ A SideClause is one of (let ([attrs (append-iattrs (map pattern-attrs (list g hp)))]) (make hpat:action attrs g hp))])) -(define (create-hpat:describe description transparent? p) - (make hpat:describe (pattern-attrs p) description transparent? p)) +(define (create-hpat:describe p description transparent? role) + (make hpat:describe (pattern-attrs p) p description transparent? role)) (define (create-hpat:and hp sp) (make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp)) diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index 7b9dfea3ba..063bac9455 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -260,7 +260,7 @@ (match entry [(struct den:lit (_i _e _ip _lp)) (values entry null)] - [(struct den:magic-class (name class argu)) + [(struct den:magic-class (name class argu role)) (values entry null)] [(struct den:class (name class argu)) ;; FIXME: integrable syntax classes? @@ -555,7 +555,7 @@ (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] [attr-count (length iattrs)]) (list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt)) - (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f) + (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f) (eh-alternative-repc alt)) (replace-eh-alternative-attrs alt (iattrs->sattrs iattrs))))))] @@ -609,59 +609,33 @@ (match entry [(struct den:lit (internal literal input-phase lit-phase)) (create-pat:literal literal input-phase lit-phase)] - [(struct den:magic-class (name class argu)) + [(struct den:magic-class (name class argu role)) (let* ([pos-count (length (arguments-pargs argu))] [kws (arguments-kws argu)] - [sc (get-stxclass/check-arity class class pos-count kws)] - [splicing? (stxclass-splicing? sc)] - [attrs (stxclass-attrs sc)] - [parser (stxclass-parser sc)] - [commit? (stxclass-commit? sc)] - [delimit-cut? (stxclass-delimit-cut? sc)]) - (check-no-delimit-cut-in-not id delimit-cut?) - (if splicing? - (begin - (unless allow-head? - (wrong-syntax id "splicing syntax class not allowed here")) - (parse-pat:id/h id parser argu attrs commit?)) - (parse-pat:id/s id parser argu attrs commit?)))] + [sc (get-stxclass/check-arity class class pos-count kws)]) + (parse-pat:var* id allow-head? id sc argu "." role #f))] [(struct den:class (_n _c _a)) (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] [(struct den:parser (parser attrs splicing? commit? delimit-cut?)) - (begin - (check-no-delimit-cut-in-not id delimit-cut?) - (if splicing? - (begin - (unless allow-head? - (wrong-syntax id "splicing syntax class not allowed here")) - (parse-pat:id/h id parser no-arguments attrs commit?)) - (parse-pat:id/s id parser no-arguments attrs commit?)))] + (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)] + [else + (parse-pat:id/s id parser no-arguments attrs commit? "." #f)])] [(struct den:delayed (parser class)) (let ([sc (get-stxclass class)]) - (check-no-delimit-cut-in-not id (stxclass-delimit-cut? sc)) - (cond [(stxclass/s? sc) - (parse-pat:id/s id - parser - no-arguments - (stxclass-attrs sc) - (stxclass-commit? sc))] - [(stxclass/h? sc) - (unless allow-head? - (wrong-syntax id "splicing syntax class not allowed here")) - (parse-pat:id/h id - parser - no-arguments - (stxclass-attrs sc) - (stxclass-commit? sc))]))] + (parse-pat:var* id allow-head? id sc no-arguments "." #f parser))] ['#f (unless (safe-name? id) (wrong-syntax id "expected identifier not starting with ~~ character")) (let-values ([(name sc) (split-id/get-stxclass id decls)]) (if sc - (parse-pat:var* id allow-head? name sc no-arguments) - (create-pat:var name #f no-arguments null #f #t)))])) + (parse-pat:var* id allow-head? name sc no-arguments "." #f #f) + (create-pat:var name #f no-arguments null #f #t #f)))])) (define (parse-pat:var stx decls allow-head?) (define name0 @@ -672,10 +646,10 @@ #'name] [_ (wrong-syntax stx "bad ~~var form")])) - (define-values (scname sc+args-stx argu pfx) + (define-values (scname sc+args-stx argu pfx role) (syntax-case stx (~var) [(~var _name) - (values #f #f null #f)] + (values #f #f null #f #f)] [(~var _name sc/sc+args . rest) (let-values ([(sc argu) (let ([p (check-stxclass-application #'sc/sc+args stx)]) @@ -686,7 +660,8 @@ #:context stx)) (define sep (options-select-value chunks '#:attr-name-separator #:default #f)) - (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".")))] + (define role (options-select-value chunks '#:role #:default #'#f)) + (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))] [_ (wrong-syntax stx "bad ~~var form")])) (cond [(and (epsilon? name0) (not scname)) @@ -697,46 +672,51 @@ (let ([sc (get-stxclass/check-arity scname sc+args-stx (length (arguments-pargs argu)) (arguments-kws argu))]) - (parse-pat:var* stx allow-head? name0 sc argu pfx))] + (parse-pat:var* stx allow-head? name0 sc argu pfx role #f))] [else ;; Just proper name - (create-pat:var name0 #f (arguments null null null) null #f #t)])) + (create-pat:var name0 #f (arguments null null null) null #f #t #f)])) -(define (parse-pat:var* stx allow-head? name sc argu [pfx "."]) +(define (parse-pat:var* stx allow-head? name sc argu pfx role parser*) + ;; if parser* not #f, overrides sc parser (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc)) - (cond [(stxclass/s? sc) - (if (and (stxclass-integrate sc) (equal? argu no-arguments)) - (parse-pat:id/s/integrate name (stxclass-integrate sc)) - (parse-pat:id/s name - (stxclass-parser sc) - argu - (stxclass-attrs sc) - (stxclass-commit? sc) - pfx))] + (cond [(and (stxclass/s? sc) + (stxclass-integrate sc) + (equal? argu no-arguments)) + (parse-pat:id/s/integrate name (stxclass-integrate sc) role)] + [(stxclass/s? sc) + (parse-pat:id/s name + (or parser* (stxclass-parser sc)) + argu + (stxclass-attrs sc) + (stxclass-commit? sc) + pfx + role)] [(stxclass/h? sc) (unless allow-head? (wrong-syntax stx "splicing syntax class not allowed here")) (parse-pat:id/h name - (stxclass-parser sc) + (or parser* (stxclass-parser sc)) argu (stxclass-attrs sc) (stxclass-commit? sc) - pfx)])) + pfx + role)])) -(define (parse-pat:id/s name parser argu attrs commit? [pfx "."]) +(define (parse-pat:id/s name parser argu attrs commit? pfx role) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?)) + (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) -(define (parse-pat:id/s/integrate name integrate) +(define (parse-pat:id/s/integrate name integrate role) (define bind (name->bind name)) - (create-pat:integrated bind - (integrate-predicate integrate) - (integrate-description integrate))) + (let ([predicate (integrate-predicate integrate)] + [description (integrate-description integrate)]) + (create-pat:integrated bind predicate description role))) -(define (parse-pat:id/h name parser argu attrs commit? [pfx "."]) +(define (parse-pat:id/h name parser argu attrs commit? pfx role) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?)) + (create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) (define (name->prefix id pfx) (cond [(wildcard? id) #f] @@ -810,12 +790,13 @@ #:no-duplicates? #t #:context stx)]) (define transparent? (not (assq '#:opaque chunks))) + (define role (options-select-value chunks '#:role #:default #'#f)) (syntax-case rest () [(description pattern) (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) (if (head-pattern? p) - (create-hpat:describe #'description transparent? p) - (create-pat:describe #'description transparent? p)))]))])) + (create-hpat:describe p #'description transparent? role) + (create-pat:describe p #'description transparent? role)))]))])) (define (parse-pat:delimit stx decls allow-head?) (syntax-case stx () @@ -1155,6 +1136,9 @@ [(cons (list '#:declare declare-stx _ _) rest) (wrong-syntax declare-stx "#:declare can only follow pattern or #:with clause")] + [(cons (list '#:role role-stx _) rest) + (wrong-syntax role-stx + "#:role can only follow immediately after #:declare clause")] [(cons (list '#:fail-when fw-stx when-condition expr) rest) (cons (make clause:fail when-condition expr) (parse-pattern-sides rest decls))] @@ -1182,23 +1166,30 @@ ;; grab-decls : (listof chunk) DeclEnv ;; -> (values DeclEnv (listof chunk)) (define (grab-decls chunks decls0) - (define (add-decl stx decls) - (syntax-case stx () - [(#:declare name sc) - (identifier? #'sc) - (add-decl* decls #'name #'sc (parse-argu null))] - [(#:declare name (sc expr ...)) - (identifier? #'sc) - (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))))] - [(#:declare name bad-sc) - (wrong-syntax #'bad-sc - "expected syntax class name (possibly with parameters)")])) - (define (add-decl* decls id sc-name argu) - (declenv-put-stxclass decls id sc-name argu)) + (define (add-decl stx role-stx decls) + (let ([role + (and role-stx + (syntax-case role-stx () + [(#:role role) #'role]))]) + (syntax-case stx () + [(#:declare name sc) + (identifier? #'sc) + (add-decl* decls #'name #'sc (parse-argu null) role)] + [(#:declare name (sc expr ...)) + (identifier? #'sc) + (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)] + [(#:declare name bad-sc) + (wrong-syntax #'bad-sc + "expected syntax class name (possibly with parameters)")]))) + (define (add-decl* decls id sc-name argu role) + (declenv-put-stxclass decls id sc-name argu role)) (define (loop chunks decls) (match chunks + [(cons (cons '#:declare decl-stx) + (cons (cons '#:role role-stx) rest)) + (loop rest (add-decl decl-stx role-stx decls))] [(cons (cons '#:declare decl-stx) rest) - (loop rest (add-decl decl-stx decls))] + (loop rest (add-decl decl-stx #f decls))] [_ (values decls chunks)])) (loop chunks decls0)) @@ -1515,6 +1506,7 @@ ;; pattern-directive-table (define pattern-directive-table (list (list '#:declare check-identifier check-expression) + (list '#:role check-expression) ;; attached to preceding #:declare (list '#:fail-when check-expression check-expression) (list '#:fail-unless check-expression check-expression) (list '#:when check-expression) @@ -1529,7 +1521,8 @@ ;; describe-option-table (define describe-option-table - (list (list '#:opaque))) + (list (list '#:opaque) + (list '#:role check-expression))) ;; eh-optional-directive-table (define eh-optional-directive-table @@ -1552,4 +1545,5 @@ ;; var-pattern-directive-table (define var-pattern-directive-table - (list (list '#:attr-name-separator check-stx-string))) + (list (list '#:attr-name-separator check-stx-string) + (list '#:role check-expression))) diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt index a51bbfe136..4f244b6ed5 100644 --- a/collects/syntax/parse/private/residual.rkt +++ b/collects/syntax/parse/private/residual.rkt @@ -48,6 +48,7 @@ (provide (all-from-out "runtime-progress.rkt") this-syntax + this-role this-context-syntax attribute attribute-binding @@ -70,6 +71,10 @@ (lambda (stx) (raise-syntax-error #f "used out of context: not within a syntax class" stx))) +(define-syntax-parameter this-role + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + ;; this-context-syntax ;; Bound to (expression that extracts) context syntax (bottom frame in progress) (define-syntax-parameter this-context-syntax @@ -198,7 +203,7 @@ (provide predicate-ellipsis-parser) -(define (predicate-ellipsis-parser x cx pr es pred? desc) +(define (predicate-ellipsis-parser x cx pr es pred? desc rl) (let ([elems (stx->list x)]) (if (and elems (andmap pred? elems)) (values 'ok elems) @@ -210,9 +215,13 @@ (loop (cdr x) cx (add1 i)) (let* ([pr (ps-add-cdr pr i)] [pr (ps-add-car pr)] - [es (cons (expect:thing desc #t) es)]) + [es (cons (expect:thing desc #t rl) es)]) (values 'fail (failure pr es))))] [else ;; not null, because stx->list failed (let ([pr (ps-add-cdr pr i)] - [es (cons (expect:atom '()) es)]) + #| + ;; Don't extend es! That way we don't get spurious "expected ()" + ;; that *should* have been cancelled out by ineffable pair failures. + [es (cons (expect:atom '()) es)] + |#) (values 'fail (failure pr es)))]))))) diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt index 562f1f244a..455627cc3c 100644 --- a/collects/syntax/parse/private/runtime-progress.rkt +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -181,7 +181,7 @@ Interpretation: Inner PS structures are applied first. An ExpectStack is (listof Expect) An Expect is one of - - (make-expect:thing string boolean) + - (make-expect:thing string boolean string/#f) * (make-expect:message string) * (make-expect:atom atom) * (make-expect:literal identifier) @@ -189,7 +189,7 @@ An Expect is one of The *-marked variants can only occur at the top of the stack. |# -(define-struct expect:thing (description transparent?) #:prefab) +(define-struct expect:thing (description transparent? role) #:prefab) (define-struct expect:message (message) #:prefab) (define-struct expect:atom (atom) #:prefab) (define-struct expect:literal (literal) #:prefab) diff --git a/collects/syntax/parse/private/runtime-reflect.rkt b/collects/syntax/parse/private/runtime-reflect.rkt index e542f7c77d..63dc1bb996 100644 --- a/collects/syntax/parse/private/runtime-reflect.rkt +++ b/collects/syntax/parse/private/runtime-reflect.rkt @@ -66,8 +66,8 @@ A Reified is [else (loop (cdr result) indexes (add1 i))]))) (make-keyword-procedure - (lambda (kws kwargs x cx pr es fh cp success . rest) - (keyword-apply parser kws kwargs x cx pr es fh cp + (lambda (kws kwargs x cx pr es fh cp rl success . rest) + (keyword-apply parser kws kwargs x cx pr es fh cp rl (if splicing? (lambda (fh x cx pr . result) (apply success fh x cx pr (take-indexes result indexes))) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt index 83d251f3b2..61803e02f8 100644 --- a/collects/syntax/parse/private/runtime-report.rkt +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -8,6 +8,12 @@ current-failure-handler maximal-failures) +#| +TODO: given (expect:thing D _ R) and (expect:thing D _ #f), + simplify to (expect:thing D _ #f) + thus, "expected D" rather than "expected D or D for R" (?) +|# + #| Note: there is a cyclic dependence between residual.rkt and this module, broken by a lazy-require of this module into residual.rkt @@ -81,6 +87,7 @@ complicated. (report/expects (list frame-expect) frame-stx)]))]))) ;; report/expects : (listof Expect) syntax -> Report +;; FIXME: partition by role first? (define (report/expects expects frame-stx) (report (join-sep (for/list ([expect expects]) (prose-for-expect expect)) @@ -90,8 +97,10 @@ complicated. ;; prose-for-expect : Expect -> string (define (prose-for-expect e) (match e - [(expect:thing description transparent?) - (format "expected ~a" description)] + [(expect:thing description transparent? role) + (if role + (format "expected ~a for ~a" description role) + (format "expected ~a" description))] [(expect:atom atom) (format "expected the literal ~a~s~a" (if (symbol? atom) "symbol `" "") @@ -157,10 +166,11 @@ complicated. (let loop ([es es]) (match es ['() '()] - [(cons (expect:thing description '#f) rest-es) + [(cons (expect:thing description '#f role) rest-es) ;; Tricky! If multiple opaque frames, multiple "returns", ;; but innermost one called first, so jumps past the rest. - (return (cons (car es) (loop rest-es)))] + ;; Also, flip opaque to transparent for sake of equality. + (return (cons (expect:thing description #t role) (loop rest-es)))] [(cons expect rest-es) (cons expect (loop rest-es))])))) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 602c05d261..45743813ac 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -211,8 +211,8 @@ residual.rkt. (length (syntax->list #'(parg ...))) (syntax->datum #'(kw ...)))]) (with-syntax ([parser (stxclass-parser sc)]) - #'(lambda (x cx pr es fh cp success) - (app-argu parser x cx pr es fh cp success argu)))))])) + #'(lambda (x cx pr es fh cp rl success) + (app-argu parser x cx pr es fh cp rl success argu)))))])) (define-syntax (app-argu stx) (syntax-case stx () diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl index f43f07d726..09a46da28a 100644 --- a/collects/syntax/scribblings/parse/litconv.scrbl +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -120,9 +120,9 @@ the @racket[_phase] argument defaults to Defines @deftech{conventions} that supply default syntax classes for pattern variables. A pattern variable that has no explicit syntax -class is checked against each @racket[id-pattern], and the first one +class is checked against each @racket[name-pattern], and the first one that matches determines the syntax class for the pattern. If no -@racket[id-pattern] matches, then the pattern variable has no syntax +@racket[name-pattern] matches, then the pattern variable has no syntax class. @myexamples[ diff --git a/collects/syntax/scribblings/parse/patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl index 8154b62877..481a36a888 100644 --- a/collects/syntax/scribblings/parse/patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -38,8 +38,8 @@ means specifically @tech{@Spattern}. pvar-id:syntax-class-id literal-id (@#,ref[~var s-] id) - (@#,ref[~var s+] id syntax-class-id) - (@#,ref[~var s+] id (syntax-class-id arg ...)) + (@#,ref[~var s+] id syntax-class-id maybe-role) + (@#,ref[~var s+] id (syntax-class-id arg ...) maybe-role) (~literal literal-id) atomic-datum (~datum datum) @@ -54,7 +54,7 @@ means specifically @tech{@Spattern}. #s(prefab-struct-key (unsyntax @svar[pattern-part]) ...) #&@#,svar[S-pattern] (~rest S-pattern) - (@#,ref[~describe s] maybe-opaque expr S-pattern) + (@#,ref[~describe s] maybe-opaque maybe-role expr S-pattern) (@#,ref[~commit s] S-pattern) (@#,ref[~delimit-cut s] S-pattern) A-pattern] @@ -67,13 +67,14 @@ means specifically @tech{@Spattern}. (~rest L-pattern)] [H-pattern pvar-id:splicing-syntax-class-id - (@#,ref[~var h] id splicing-syntax-class-id) - (@#,ref[~var h] id (splicing-syntax-class-id arg ...)) + (@#,ref[~var h] id splicing-syntax-class-id maybe-role) + (@#,ref[~var h] id (splicing-syntax-class-id arg ...) + maybe-role) (~seq . L-pattern) (@#,ref[~and h] proper-H/A-pattern ...+) (@#,ref[~or h] H-pattern ...+) (@#,ref[~optional h] H-pattern maybe-optional-option) - (@#,ref[~describe h] maybe-opaque expr H-pattern) + (@#,ref[~describe h] maybe-opaque maybe-role expr H-pattern) (@#,ref[~commit h] H-pattern) (@#,ref[~delimit-cut h] H-pattern) (~peek H-pattern) @@ -255,9 +256,12 @@ like an @tech{annotated pattern variable} with the implicit syntax class inserted. } -@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use) +@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use maybe-role) ([syntax-class-use syntax-class-id - (syntax-class-id arg ...)])]{ + (syntax-class-id arg ...)] + [maybe-role (code:line) + (code:line #:role role-expr)]) + #:contracts ([role-expr (or/c string? #f)])]{ An @deftech{annotated pattern variable}. The pattern matches only terms accepted by @svar[syntax-class-id] (parameterized by the @@ -271,6 +275,9 @@ character) to the name of the syntax class's attribute. If @svar[pvar-id] is @racket[_], no attributes are bound. +If @racket[role-expr] is given and evaluates to a string, it is +combined with the syntax class's description in error messages. + @myexamples[ (syntax-parse #'a [(~var var id) (syntax-e #'var)]) @@ -286,6 +293,8 @@ If @svar[pvar-id] is @racket[_], no attributes are bound. (syntax-parse #'(1 2 3 4 5) [((~var small (nat-less-than 4)) ... large:nat ...) (list #'(small ...) #'(large ...))]) +(syntax-parse #'(m a b 3) + [(_ (~var x id #:role "variable") ...) 'ok]) ] } @@ -537,15 +546,35 @@ above). @specsubform/subs[(@#,def[~describe s] maybe-opaque expr S-pattern) ([maybe-opaque (code:line) - (code:line #:opaque)]) - #:contracts ([expr (or/c string? #f)])]{ + (code:line #:opaque)] + [maybe-role (code:line) + (code:line #:role role-expr)]) + #:contracts ([expr (or/c string? #f)] + [role-expr (or/c string? #f)])]{ The @racket[~describe] pattern form annotates a pattern with a description, a string expression that is evaluated in the scope of all prior attribute bindings. If parsing the inner pattern fails, then the -description is used to synthesize the error message. +description is used to synthesize the error message. A +@racket[~describe] pattern does not influence backtracking. -A @racket[~describe] pattern has no effect on backtracking. +If @racket[#:opaque] is given, failure information from within +@racket[S-pattern] is discarded and the error is reported solely in +terms of the description given. + +If @racket[role-expr] is given and produces a string, its value is +combined with the description in error messages. + +@myexamples[ +(syntax-parse #'(m 1) + [(_ (~describe "id pair" (x:id y:id))) 'ok]) +(syntax-parse #'(m (a 2)) + [(_ (~describe "id pair" (x:id y:id))) 'ok]) +(syntax-parse #'(m (a 2)) + [(_ (~describe #:opaque "id pair" (x:id y:id))) 'ok]) +(syntax-parse #'(m 1) + [(_ (~describe #:role "formals" "id pair" (x y))) 'ok]) +] } @specsubform[(@#,def[~commit s] S-pattern)]{ @@ -605,9 +634,12 @@ Equivalent to @racket[(~var pvar-id splicing-syntax-class-id)]. } -@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use) +@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use maybe-role) ([splicing-syntax-class-use splicing-syntax-class-id - (splicing-syntax-class-id arg ...)])]{ + (splicing-syntax-class-id arg ...)] + [maybe-role (code:line) + (code:line #:role role-expr)]) + #:contracts ([role-expr (or/c string? #f)])]{ Pattern variable annotated with a @tech{splicing syntax class}. Similar to a normal @tech{annotated pattern variable}, except @@ -754,9 +786,9 @@ outside of the @racket[~peek-not]-pattern. (pattern (~seq x (~peek-not _)))) (syntax-parse #'(a b c) - [((~or f:final o:other) ...) + [((~or f:final other) ...) (printf "finals are ~s\n" (syntax->datum #'(f.x ...))) - (printf "others are ~s\n" (syntax->datum #'(o ...)))]) + (printf "others are ~s\n" (syntax->datum #'(other ...)))]) ] } @@ -891,13 +923,13 @@ forms based on keywords. Consider the following expression: [(define-syntaxes (x:id ...) e) 'define-syntaxes] [e 'expression])] -Given the ill-formed term @racket[(define-values a 123)], the -expression tries the first clause, fails to match @racket[a] against -the pattern @racket[(x:id ...)], and then backtracks to the second -clause and ultimately the third clause, producing the value -@racket['expression]. But the term is not an expression; it is an -ill-formed use of @racket[define-values]. The proper way to write the -@racket[syntax-parse] expression follows: +Given the ill-formed term @racket[(define-values a 123)], +@racket[syntax-parse] tries the first clause, fails to match +@racket[a] against the pattern @racket[(x:id ...)], and then +backtracks to the second clause and ultimately the third clause, +producing the value @racket['expression]. But the term is not an +expression; it is an ill-formed use of @racket[define-values]. The +proper way to write the @racket[syntax-parse] expression follows: @interaction[#:eval the-eval (syntax-parse #'(define-values a 123) diff --git a/collects/syntax/scribblings/parse/stxclasses.scrbl b/collects/syntax/scribblings/parse/stxclasses.scrbl index be1f8b3551..2a460d99f4 100644 --- a/collects/syntax/scribblings/parse/stxclasses.scrbl +++ b/collects/syntax/scribblings/parse/stxclasses.scrbl @@ -171,8 +171,7 @@ specifying side conditions. The grammar for pattern directives follows: @racketgrammar[pattern-directive - (code:line #:declare pattern-id syntax-class-id) - (code:line #:declare pattern-id (syntax-class-id arg ...)) + (code:line #:declare pattern-id stxclass maybe-role) (code:line #:with syntax-pattern expr) (code:line #:attr attr-arity-decl expr) (code:line #:fail-when condition-expr message-expr) @@ -180,18 +179,20 @@ follows: (code:line #:when condition-expr) (code:line #:do [def-or-expr ...])] -@specsubform[(code:line #:declare pvar-id syntax-class-id)] -@specsubform[(code:line #:declare pvar-id (syntax-class-id arg ...))]{ +@specsubform/subs[(code:line #:declare pvar-id stxclass maybe-role) + ([stxclass syntax-class-id + (syntax-class-id arg ...)] + [maybe-role (code:line) + (code:line #:role role-expr)])]{ -The first form is equivalent to using the -@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal -to use both for the same pattern variable). - -The second form allows the use of parameterized syntax classes, which -cannot be expressed using the ``colon'' notation. The @racket[arg]s -are evaluated outside the scope of any of the attribute bindings from -pattern that the @racket[#:declare] directive applies to. Keyword -arguments are supported, using the same syntax as in @racket[#%app]. +Associates @racket[pvar-id] with a syntax class and possibly a role, +equivalent to replacing each occurrence of @racket[pvar-id] in the +pattern with @racket[(~var pvar-id stxclass maybe-role)]. +The second form of @racket[stxclass] allows the use of parameterized +syntax classes, which cannot be expressed using the ``colon'' +notation. The @racket[arg]s are evaluated in the scope where the +@racket[pvar-id] occurs in the pattern. Keyword arguments are +supported, using the same syntax as in @racket[#%app]. } @specsubform[(code:line #:with syntax-pattern stx-expr)]{ diff --git a/collects/tests/stxparse/select.rkt b/collects/tests/stxparse/select.rkt index 3ea559f0c4..9666e508f5 100644 --- a/collects/tests/stxparse/select.rkt +++ b/collects/tests/stxparse/select.rkt @@ -108,3 +108,34 @@ (terx (1 a 2 b) ((~or (~once x:id #:name "identifier") n:nat) ...) #rx"too many occurrences of identifier") + +;; Roles + +(terx 1 + (~var x id #:role "var") + #rx"expected identifier for var") +(terx 1 + (~describe #:opaque #:role "R" "D" (_)) + #rx"expected D for R") +(terx 1 + (~describe #:role "R" "D" (_)) + #rx"expected D for R") + +(test-case "#:describe #:role" + (check-exn #rx"expected identifier for var" + (lambda () + (syntax-parse #'1 + [x + #:declare x id #:role "var" + 'ok])))) + +(test-case "role coalescing" + (check-exn #rx"^m: expected identifier for thing$" ;; not repeated + (lambda () + (syntax-parse #'(m 0 b) + [(_ x y:nat) + #:declare x id #:role "thing" + 'a] + [(_ x y:id) + #:declare x id #:role "thing" + 'b]))))