auto-force attributes in syntax templates
This commit is contained in:
Ryan Culpepper
parent
aaaebe2e41
commit
aff7153494
|
|
@ -696,7 +696,7 @@ Conventions:
|
|||
(for/fold ([k #'k]) ([side (in-list (reverse (syntax->list #'(side ...))))])
|
||||
(syntax-case side ()
|
||||
[#s(clause:attr a expr)
|
||||
#`(let-attributes ([a (wrap-user-code (check-list^depth a expr))])
|
||||
#`(let-attributes ([a (wrap-user-code expr)])
|
||||
#,k)]))]))
|
||||
|
||||
(begin-for-syntax
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/stxparam
|
||||
racket/lazy-require)
|
||||
racket/lazy-require
|
||||
racket/private/promise)
|
||||
|
||||
;; ============================================================
|
||||
;; Compile-time
|
||||
|
|
@ -33,10 +34,11 @@
|
|||
[else #f]))
|
||||
(attribute-mapping-name self))])
|
||||
#`(let ([value #,(attribute-mapping-var self)])
|
||||
(check-attr-value-is-syntax '#,(attribute-mapping-depth self)
|
||||
value
|
||||
(quote-syntax #,source-name))
|
||||
value)))))
|
||||
(if (syntax-list^depth? '#,(attribute-mapping-depth self) value)
|
||||
value
|
||||
(check/force-syntax-list^depth '#,(attribute-mapping-depth self)
|
||||
value
|
||||
(quote-syntax #,source-name))))))))
|
||||
)
|
||||
|
||||
;; ============================================================
|
||||
|
|
@ -54,7 +56,6 @@
|
|||
attribute-binding
|
||||
stx-list-take
|
||||
stx-list-drop/cx
|
||||
check-list^depth*
|
||||
check-literal*
|
||||
begin-for-syntax/once
|
||||
|
||||
|
|
@ -131,30 +132,45 @@
|
|||
(if (syntax? x) x cx)
|
||||
(sub1 n)))))
|
||||
|
||||
;; check-attr-value-is-syntax : nat any id -> boolean
|
||||
;; returns #t if value is a (listof^depth syntax)
|
||||
;; used by attribute-mapping code above
|
||||
(define (check-attr-value-is-syntax depth value source-id)
|
||||
(define (check-syntax depth value)
|
||||
(if (zero? depth)
|
||||
(syntax? value)
|
||||
(and (list? value)
|
||||
(for/and ([part (in-list value)])
|
||||
(check-syntax (sub1 depth) part)))))
|
||||
(unless (check-syntax depth value)
|
||||
;; check/force-syntax-list^depth : nat any id -> (listof^depth syntax)
|
||||
;; Checks that value is (listof^depth syntax); forces promises.
|
||||
;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already.
|
||||
(define (check/force-syntax-list^depth depth value0 source-id)
|
||||
(define (bad)
|
||||
(raise-syntax-error #f
|
||||
(format "attribute is bound to non-syntax value: ~e" value)
|
||||
source-id)))
|
||||
(format "attribute is bound to non-syntax value: ~e" value0)
|
||||
source-id))
|
||||
(define (loop depth value)
|
||||
(cond [(promise? value)
|
||||
(loop depth (force value))]
|
||||
[(zero? depth)
|
||||
(if (syntax? value) value (bad))]
|
||||
[else (loop-list depth value)]))
|
||||
(define (loop-list depth value)
|
||||
(cond [(promise? value)
|
||||
(loop-list depth (force value))]
|
||||
[(pair? value)
|
||||
(let ([new-car (loop (sub1 depth) (car value))]
|
||||
[new-cdr (loop-list depth (cdr value))])
|
||||
;; Don't copy unless necessary
|
||||
(if (and (eq? new-car (car value))
|
||||
(eq? new-cdr (cdr value)))
|
||||
value
|
||||
(cons new-car new-cdr)))]
|
||||
[(null? value)
|
||||
null]
|
||||
[else
|
||||
(bad)]))
|
||||
(loop depth value0))
|
||||
|
||||
;; check-list^depth* : symbol nat any -> list^depth
|
||||
(define (check-list^depth* aname n0 v0)
|
||||
(define (loop n v)
|
||||
(when (positive? n)
|
||||
(unless (list? v)
|
||||
(raise-type-error aname (format "lists nested ~s deep" n0) v))
|
||||
(for ([x (in-list v)]) (loop (sub1 n) x))))
|
||||
(loop n0 v0)
|
||||
v0)
|
||||
;; syntax-list^depth? : nat any -> boolean
|
||||
;; Returns true iff value is (listof^depth syntax).
|
||||
(define (syntax-list^depth? depth value)
|
||||
(if (zero? depth)
|
||||
(syntax? value)
|
||||
(and (list? value)
|
||||
(for/and ([part (in-list value)])
|
||||
(syntax-list^depth? (sub1 depth) part)))))
|
||||
|
||||
;; check-literal* : id phase phase (listof phase) stx -> void
|
||||
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@
|
|||
let/unpack
|
||||
|
||||
defattrs/unpack
|
||||
check-list^depth
|
||||
|
||||
check-literal
|
||||
no-shadow
|
||||
|
|
@ -142,14 +141,6 @@ residual.rkt.
|
|||
(define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
|
||||
...)))]))
|
||||
|
||||
;; (check-list^depth attr expr)
|
||||
(define-syntax (check-list^depth stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a expr)
|
||||
(with-syntax ([#s(attr name depth syntax?) #'a])
|
||||
(quasisyntax/loc #'expr
|
||||
(check-list^depth* 'name 'depth expr)))]))
|
||||
|
||||
;; (check-literal id phase-level-expr ctx) -> void
|
||||
(define-syntax (check-literal stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -31,7 +31,8 @@
|
|||
(lambda (e) (raise (fixup e)))])
|
||||
(thunk))))])
|
||||
(make-evaluator 'racket/base
|
||||
#:requires (let ([mods '(syntax/parse
|
||||
#:requires (let ([mods '(racket/promise
|
||||
syntax/parse
|
||||
syntax/parse/debug
|
||||
syntax/parse/experimental/splicing
|
||||
syntax/parse/experimental/contract
|
||||
|
|
|
|||
|
|
@ -215,7 +215,8 @@ clause to be tried multiple times before the next clause is reached.
|
|||
|
||||
Evaluates the @racket[expr] in the context of all previous attribute
|
||||
bindings and binds it to the given attribute. The value of
|
||||
@racket[expr] need not be syntax.
|
||||
@racket[expr] need not be, or even contain, syntax---see
|
||||
@racket[attribute] for details.
|
||||
}
|
||||
|
||||
@specsubform[(code:line #:fail-when condition-expr message-expr)
|
||||
|
|
@ -261,7 +262,7 @@ in a @racket[#:do] block.
|
|||
|
||||
@;{----------}
|
||||
|
||||
@section{Pattern Variables and Attributes}
|
||||
@section[#:tag "stxparse-attrs"]{Pattern Variables and Attributes}
|
||||
|
||||
An @deftech{attribute} is a name bound by a syntax pattern. An
|
||||
attribute can be a @tech{pattern variable} itself, or it can be a
|
||||
|
|
@ -270,58 +271,92 @@ variable}. The name of a nested attribute is computed by concatenating
|
|||
the pattern variable name with the syntax class's exported attribute's
|
||||
name, separated by a dot (see the example below).
|
||||
|
||||
Attribute names cannot be used directly as expressions; that is,
|
||||
attributes are not variables. Instead, an attribute's value can be
|
||||
gotten using the @racket[attribute] special form.
|
||||
Attributes can be used in two ways: with the @racket[attribute] form,
|
||||
and inside syntax templates via @racket[syntax], @racket[quasisyntax],
|
||||
etc. Attribute names cannot be used directly as expressions; that is,
|
||||
attributes are not variables.
|
||||
|
||||
@defform[(attribute attr-id)]{
|
||||
A @deftech{syntax-valued attribute} is an attribute whose value is a
|
||||
syntax object, a syntax list of the appropriate @tech{ellipsis depth},
|
||||
or a tree containing @tech[#:doc '(lib
|
||||
"scribblings/reference/reference.scrbl")]{promises} that when
|
||||
completely forced produces a suitable syntax object or syntax
|
||||
list. Syntax-valued attributes can be used within @racket[syntax],
|
||||
@racket[quasisyntax], etc as part of a syntax template. If an
|
||||
attribute is used inside a syntax template but it is not
|
||||
syntax-valued, an error is signaled.
|
||||
|
||||
Returns the value associated with the attribute named
|
||||
@racket[attr-id]. If @racket[attr-id] is not bound as an attribute, an
|
||||
error is raised.
|
||||
}
|
||||
|
||||
The value of an attribute need not be syntax. Non-syntax-valued
|
||||
attributes can be used to return a parsed representation of a subterm
|
||||
or the results of an analysis on the subterm. A non-syntax-valued
|
||||
attribute should be bound using the @racket[#:attr] directive or a
|
||||
@racket[~bind] pattern.
|
||||
The value of an attribute is not required to be syntax.
|
||||
Non-syntax-valued attributes can be used to return a parsed
|
||||
representation of a subterm or the results of an analysis on the
|
||||
subterm. A non-syntax-valued attribute should be bound using the
|
||||
@racket[#:attr] directive or a @racket[~bind] pattern; @racket[#:with]
|
||||
and @racket[~parse] will convert the right-hand side to a (possibly
|
||||
3D) syntax object.
|
||||
|
||||
@myexamples[
|
||||
(define-syntax-class table
|
||||
(pattern ((key value) ...)
|
||||
#:attr hash
|
||||
#:attr hashtable
|
||||
(for/hash ([k (syntax->datum #'(key ...))]
|
||||
[v (syntax->datum #'(value ...))])
|
||||
(values k v))))
|
||||
(syntax-parse #'((a 1) (b 2) (c 3))
|
||||
[t:table
|
||||
(attribute t.hash)])
|
||||
(values k v))
|
||||
#:attr [sorted-kv 1]
|
||||
(delay
|
||||
(printf "sorting!\n")
|
||||
(sort (syntax->list #'((key value) ...))
|
||||
<
|
||||
#:key (lambda (kv) (cadr (syntax->datum kv)))))))
|
||||
]
|
||||
|
||||
A syntax-valued attribute is an attribute whose value is a syntax
|
||||
object or a syntax list of the appropriate @tech{ellipsis
|
||||
depth}. Syntax-valued attributes can be used within @racket[syntax],
|
||||
@racket[quasisyntax], etc as part of a syntax template. If a
|
||||
non-syntax-valued attribute is used in a syntax template, a runtime
|
||||
error is signaled.
|
||||
The @racket[table] syntax class provides four attributes:
|
||||
@racket[key], @racket[value], @racket[hashtable], and
|
||||
@racket[sorted-kv]. The @racket[hashtable] attribute has
|
||||
@tech{ellipsis depth} 0 and the rest have depth 1; all but
|
||||
@racket[hashtable] are syntax-valued. The @racket[sorted-kv]
|
||||
attribute's value is a promise; it will be automatically forced if
|
||||
used in a syntax template.
|
||||
|
||||
@myexamples[
|
||||
(syntax-parse #'((a 1) (b 2) (c 3))
|
||||
Syntax-valued attributes can be used in syntax templates:
|
||||
|
||||
@myinteraction[
|
||||
(syntax-parse #'((a 3) (b 2) (c 1))
|
||||
[t:table
|
||||
#'(t.key ...)])
|
||||
(syntax-parse #'((a 3) (b 2) (c 1))
|
||||
[t:table
|
||||
#'(t.sorted-kv ...)])]
|
||||
|
||||
But non-syntax-valued attributes cannot:
|
||||
|
||||
@myinteraction[
|
||||
(syntax-parse #'((a 3) (b 2) (c 1))
|
||||
[t:table
|
||||
#'t.hashtable])
|
||||
]
|
||||
|
||||
Use the @racket[attribute] form to get the value of an attribute
|
||||
(syntax-valued or not).
|
||||
|
||||
@myinteraction[
|
||||
(syntax-parse #'((a 1) (b 2) (c 3))
|
||||
[t:table
|
||||
#'t.hash])
|
||||
(attribute t.hashtable)])
|
||||
(syntax-parse #'((a 3) (b 2) (c 1))
|
||||
[t:table
|
||||
(attribute t.sorted-kv)])
|
||||
]
|
||||
|
||||
Every attribute has an associated @deftech{ellipsis depth} that
|
||||
determines how it can be used in a syntax template (see the discussion
|
||||
of ellipses in @racket[syntax]). For a pattern variable, the ellipsis
|
||||
depth is the number of ellipses the pattern variable ``occurs under''
|
||||
in the pattern. For a nested attribute the depth is the sum of the
|
||||
pattern variable's depth and the depth of the attribute in the syntax
|
||||
class. Consider the following code:
|
||||
in the pattern. An attribute bound by @racket[#:attr] has depth 0
|
||||
unless declared otherwise. For a nested attribute the depth is the sum
|
||||
of the annotated pattern variable's depth and the depth of the
|
||||
attribute exported by the syntax class.
|
||||
|
||||
Consider the following code:
|
||||
|
||||
@racketblock[
|
||||
(define-syntax-class quark
|
||||
|
|
@ -341,11 +376,20 @@ binds the following nested attributes: @racket[y.a] at depth 2,
|
|||
depth 1.
|
||||
|
||||
An attribute's ellipsis nesting depth is @emph{not} a guarantee that
|
||||
its value has that level of list nesting. In particular, @racket[~or]
|
||||
and @racket[~optional] patterns may result in attributes with fewer
|
||||
than expected levels of list nesting.
|
||||
it is syntax-valued. In particular, @racket[~or] and
|
||||
@racket[~optional] patterns may result in attributes with fewer than
|
||||
expected levels of list nesting, and @racket[#:attr] and
|
||||
@racket[~bind] can be used to bind attributes to arbitrary values.
|
||||
|
||||
@(myexamples
|
||||
(syntax-parse #'(1 2 3)
|
||||
[(~or (x:id ...) _)
|
||||
(attribute x)]))
|
||||
@myexamples[
|
||||
(syntax-parse #'(a b 3)
|
||||
[(~or (x:id ...) _)
|
||||
(attribute x)])
|
||||
]
|
||||
|
||||
@defform[(attribute attr-id)]{
|
||||
|
||||
Returns the value associated with the @tech{attribute} named
|
||||
@racket[attr-id]. If @racket[attr-id] is not bound as an attribute, an
|
||||
error is raised.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -349,6 +349,57 @@
|
|||
[ns (void)])))
|
||||
(void))
|
||||
|
||||
;; lazy attributes
|
||||
|
||||
(test-case "lazy syntax-valued attributes"
|
||||
(let ([counter 0])
|
||||
(define-syntax-class foo
|
||||
(pattern n:nat
|
||||
#:attr 2n
|
||||
(delay
|
||||
(set! counter (add1 counter))
|
||||
(datum->syntax #'n (* 2 (syntax-e #'n))))))
|
||||
(syntax-parse #'45
|
||||
[x:foo
|
||||
(check-equal? counter 0) ;; hasn't run yet
|
||||
(attribute x.2n)
|
||||
(check-pred promise? (attribute x.2n))
|
||||
(check-equal? counter 0) ;; still hasn't run yet
|
||||
#'(lambda (q) x.2n)
|
||||
(check-equal? counter 1) ;; run
|
||||
#'(lambda (q) x.2n)
|
||||
(force (attribute x.2n))
|
||||
(check-equal? counter 1) ;; still only run once
|
||||
(void)])))
|
||||
|
||||
(test-case "lazy syntax-valued attributes, lists"
|
||||
;; check both (promiseof (listof syntax)) and (listof (promiseof syntax)) work
|
||||
(let ([counter 0])
|
||||
(define-syntax-class foo
|
||||
(pattern (x:id ...)
|
||||
#:attr [alpha 1]
|
||||
(delay (set! counter (add1 counter))
|
||||
(filter (lambda (x)
|
||||
(regexp-match #rx"^[a-z]+$" (symbol->string (syntax-e x))))
|
||||
(syntax->list #'(x ...))))
|
||||
#:attr [alpha-part 1]
|
||||
(map (lambda (x)
|
||||
(delay
|
||||
(set! counter (add1 counter))
|
||||
(datum->syntax #f
|
||||
(car (regexp-match #rx"^[a-z]+" (symbol->string (syntax-e x)))))))
|
||||
(syntax->list #'(x ...)))))
|
||||
(syntax-parse #'(abc g64 xyz c%)
|
||||
[f:foo
|
||||
(check-equal? counter 0)
|
||||
(check-pred syntax? #'(f.alpha ...))
|
||||
(check-equal? (syntax->datum #'(f.alpha ...)) '(abc xyz))
|
||||
(check-equal? counter 1)
|
||||
(check-pred syntax? #'(f.alpha-part ...))
|
||||
(check-equal? (syntax->datum #'(f.alpha-part ...)) '("abc" "g" "xyz" "c"))
|
||||
(check-equal? counter 5)
|
||||
(void)])))
|
||||
|
||||
;; == Lib tests
|
||||
|
||||
;; static
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user