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

syntax/parse: Add prop:syntax-class

Browse Source
This commit is contained in:
Alexis King 2019-02-07 05:18:46 -06:00
parent 25efc68b17
commit bb42476157
8 changed files with 120 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-doc/syntax/scribblings/parse/parse-common.rkt
View File

@ -54,7 +54,8 @@
syntax/parse/experimental/reflect
syntax/parse/experimental/specialize
syntax/parse/experimental/template
syntax/parse/experimental/eh)])
syntax/parse/experimental/eh
syntax/transformer)])
`((for-syntax racket/base ,@mods)
,@mods)))))))
(when short? (the-eval '(error-print-source-location #f)))
@ -120,6 +121,7 @@
syntax/parse/experimental/specialize
syntax/parse/experimental/template
syntax/parse/experimental/eh
syntax/transformer
"parse-dummy-bindings.rkt"))
(provide (for-label (all-from-out racket/base)
(all-from-out racket/contract)
@ -132,4 +134,5 @@
(all-from-out syntax/parse/experimental/specialize)
(all-from-out syntax/parse/experimental/template)
(all-from-out syntax/parse/experimental/eh)
(all-from-out syntax/transformer)
(all-from-out "parse-dummy-bindings.rkt")))

36
pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl
View File

@ -188,6 +188,42 @@ including nested attributes produced by syntax classes associated with
the pattern variables.
}
@defthing[prop:syntax-class (struct-type-property/c (or/c identifier?
(-> any/c identifier?)))]{
A @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{structure type property} to identify
structure types that act as an alias for a @tech{syntax class} or @tech{splicing syntax class}. The
property value must be an identifier or a procedure of one argument.
When a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{transformer} is bound to an
instance of a struct with this property, then it may be used as a @tech{syntax class} or
@tech{splicing syntax class} in the same way as the bindings created by @racket[define-syntax-class]
or @racket[define-splicing-syntax-class]. If the value of the property is an identifier, then it
should be bound to a @tech{syntax class} or @tech{splicing syntax class}, and the binding will be
treated as an alias for the referenced syntax class. If the value of the property is a procedure, then
it will be applied to the value with the @racket[prop:syntax-class] property to obtain an identifier,
which will then be used as in the former case.
@examples[#:eval the-eval
(begin-for-syntax
(struct expr-and-stxclass (expr-id stxclass-id)
#:property prop:procedure
(lambda (this stx) ((set!-transformer-procedure
(make-variable-like-transformer
(expr-and-stxclass-expr-id this)))
stx))
#:property prop:syntax-class
(lambda (this) (expr-and-stxclass-stxclass-id this))))
(define-syntax is-id? (expr-and-stxclass #'identifier? #'id))
(is-id? #'x)
(syntax-parse #'x
[x:is-id? #t]
[_ #f])
]
@history[#:added "7.2.0.4"]
}
@;{--------}
@section{Pattern Directives}

58
pkgs/racket-test/tests/stxparse/test.rkt
View File

@ -633,7 +633,7 @@
#rx"identifier bound to number")
(test-case "static: works"
(check-equal?
(check-equal?
(convert-syntax-error
(let ()
(define-syntax zero 0)
@ -765,7 +765,7 @@
(let ()
(define-splicing-syntax-class binding #:literals (=)
[pattern (~seq name:id = expr:expr)])
(define-syntax ~separated
(pattern-expander
(lambda (stx)
@ -775,18 +775,18 @@
#'((~seq pat (~or* (~peek-not _)
(~seq sep (~peek _))))
ooo))]))))
(define-splicing-syntax-class bindings
[pattern (~separated (~datum /) b:binding)
#:with (name ...) #'(b.name ...)
#:with (expr ...) #'(b.expr ...)])
(define (parse-my-let stx)
(syntax-parse stx
[(_ bs:bindings body)
#'(let ([bs.name bs.expr] ...)
body)]))
(check-equal? (syntax->datum
(parse-my-let #'(my-let (x = 1 / y = 2 / z = 3)
(+ x y z))))
@ -995,3 +995,51 @@
(syntax-parse #'bad
[(~var y thing #:attr-name-separator "_") #'y_a]))
'okay))
;; prop:syntax-class with id
(let ()
(define (is-id? stx)
(define-syntax indirect-id
(let ()
(struct indirect-stxclass ()
#:property prop:syntax-class #'id)
(indirect-stxclass)))
(syntax-parse stx
[_:indirect-id #t]
[_ #f]))
(check-true (is-id? #'x))
(check-false (is-id? #'42)))
;; prop:syntax-class with procedure
(let ()
(define (type-of stx)
(define-syntaxes [indirect-id indirect-string]
(let ()
(struct indirect-stxclass (id)
#:property prop:syntax-class (lambda (v) (indirect-stxclass-id v)))
(values (indirect-stxclass #'id) (indirect-stxclass #'string))))
(syntax-parse stx
[_:indirect-id 'id]
[_:indirect-string 'string]
[_ #f]))
(check-equal? (type-of #'x) 'id)
(check-equal? (type-of #'"hello") 'string)
(check-equal? (type-of #'42) #f))
;; prop:syntax-class to non-stxclass
(check-exn
(lambda (exn) (and (exn:fail:syntax? exn)
(string=? (exn-message exn) "syntax-parse: not defined as syntax class")
(equal? (map syntax-e (exn:fail:syntax-exprs exn))
(list 'not-a-syntax-class 'indirect-bad))))
(lambda ()
(convert-syntax-error
(let ()
(define-syntax indirect-bad
(let ()
(struct indirect-stxclass ()
#:property prop:syntax-class #'not-a-syntax-class)
(indirect-stxclass)))
(syntax-parse #'#f
[_:indirect-bad #t]
[_ #f])))))

2
racket/collects/syntax/parse.rkt
View File

@ -15,6 +15,8 @@
syntax/parse/private/residual-ct)
(provide pattern-expander?
(contract-out
[prop:syntax-class
(struct-type-property/c (or/c identifier? (-> any/c identifier?)))]
[pattern-expander
(-> (-> syntax? syntax?) pattern-expander?)]
[prop:pattern-expander

4
racket/collects/syntax/parse/debug.rkt
View File

@ -9,7 +9,9 @@
racket/pretty
"../parse.rkt"
(except-in syntax/parse/private/residual
prop:pattern-expander syntax-local-syntax-parse-pattern-introduce)
prop:syntax-class
prop:pattern-expander
syntax-local-syntax-parse-pattern-introduce)
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"

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

@ -225,10 +225,17 @@ expressions are duplicated, and may be evaluated in different scopes.
;; Stxclasses are primarily bound by env / syntax-local-value, but a few
;; are attached to existing bindings via alt-stxclass-mapping.
(define (get-stxclass id [allow-undef? #f])
(cond [(syntax-local-value/record id stxclass?) => values]
[(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr]
[allow-undef? #f]
[else (wrong-syntax id "not defined as syntax class")]))
(let loop ([id id]
[prev-ids '()])
(cond [(syntax-local-value/record id stxclass?) => values]
[(syntax-local-value/record id has-stxclass-prop?)
=> (lambda (val)
(define prop-val (stxclass-prop-ref val))
(define prop-id (if (identifier? prop-val) prop-val (prop-val val)))
(loop prop-id (cons id prev-ids)))]
[(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr]
[allow-undef? #f]
[else (wrong-syntax id #:extra prev-ids "not defined as syntax class")])))
;; check-stxclass-arity : stxclass Syntax Nat (Listof Keyword) -> Void
(define (check-stxclass-arity sc stx pos-count keywords)

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

@ -780,17 +780,15 @@
;; ----
(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f])
(cond [(and (memq (stxclass-lookup-config) '(yes try)) (get-stxclass scname #t))
(define config (stxclass-lookup-config))
(cond [(and (memq config '(yes try)) (get-stxclass scname (eq? config 'try)))
=> (lambda (sc)
(unless parser*
(check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu)))
(parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))]
[(memq (stxclass-lookup-config) '(try no))
[else
(define bind (name->bind varname))
(pat:fixup stx bind varname scname argu pfx role parser*)]
[else (wrong-syntax scname "not defined as syntax class (config=~s)"
;; XXX FIXME
(stxclass-lookup-config))]))
(pat:fixup stx bind varname scname argu pfx role parser*)]))
;; ----
@ -1658,7 +1656,7 @@
(syntax->list #'(e ...))]
[_
(raise-syntax-error #f "expected list of expressions and definitions" ctx stx)]))
;; Arguments and Arities
;; parse-argu : (listof stx) -> Arguments

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

@ -11,6 +11,9 @@
(struct-out den:lit)
(struct-out den:datum-lit)
(struct-out den:delayed)
prop:syntax-class
has-stxclass-prop?
stxclass-prop-ref
alt-stxclass-mapping
log-syntax-parse-error
log-syntax-parse-warning
@ -39,6 +42,9 @@
inline ;; Id/#f, reference to a predicate
) #:prefab)
(define-values [prop:syntax-class has-stxclass-prop? stxclass-prop-ref]
(make-struct-type-property 'syntax-class))
;; alt-stxclass-mapping : (boxof (listof (pair Identifier Stxclass)))
;; Maps existing bindings (can't use syntax-local-value mechanism) to stxclasses.
;; Uses alist to avoid residual dependence on syntax/id-table.