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

wrap-expr/c: Add #:phase argument to control phase of introduced syntax

Browse Source 
closes #2455
This commit is contained in:
Alexis King 2019-04-26 10:48:33 -05:00
parent 1481f3e8d9
commit 930046e729
6 changed files with 247 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/racket-doc/syntax/scribblings/contract.scrbl
View File

@ -27,7 +27,8 @@ contracts to macro subexpressions.
(or/c identifier? symbol? string? #f) #f]
[#:macro macro-name
(or/c identifier? symbol? string? #f) #f]
[#:context context (or/c syntax? #f) (current-syntax-context)])
[#:context context (or/c syntax? #f) (current-syntax-context)]
[#:phase phase exact-integer? (syntax-local-phase-level)])
syntax?]{
Returns a syntax object representing an expression that applies the
@ -69,9 +70,11 @@ The other arguments have the same meaning as for @racket[expr/c].
(app (lambda (x) 'pear) 5)
]
@history[#:added "6.3" #:changed "7.2.0.3" @elem{Added the
@racket[#:arg?] keyword argument and changed the default values and
interpretation of the @racket[#:positive] and @racket[#:negative]
arguments.}]}
@history[
#:added "6.3"
#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword argument
and changed the default values and interpretation of the
@racket[#:positive] and @racket[#:negative] arguments.}
#:changed "7.3.0.3" @elem{Added the @racket[#:phase] keyword argument.}]}
@close-eval[the-eval]

21
pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl
View File

@ -61,4 +61,25 @@ produced.
(invert 0.0)
]
The following example shows a macro that uses a contracted expression
at a different phase level. The macro's @racket[_ref] argument is used
as a ``compile-time expression''---more precisely, it is used as an
expression at a phase level one higher than the use of the macro
itself. That is because the macro places the expression in the
right-hand side of a @racket[define-syntax] form. The macro uses
@racket[expr/c] with a @racket[#:phase] argument to ensure that
@racket[_ref] produces an identifier when used as a compile-time
expression.
@interaction[#:eval the-eval
(define-syntax (define-alias stx)
(syntax-parse stx
[(_ name:id ref)
#:declare ref (expr/c #'identifier?
#:phase (add1 (syntax-local-phase-level)))
#'(define-syntax name (make-rename-transformer ref.c))]))
(define-alias plus #'+)
(define-alias zero 0)
]
@(close-eval the-eval)

41
pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
View File

@ -4,8 +4,9 @@
scribble/struct
scribble/decode
scribble/eval
"../common.rkt"
"parse-common.rkt"
(for-label racket/base racket/contract syntax/kerncase))
(for-label racket/base racket/contract racket/syntax syntax/kerncase))
@title{Library Syntax Classes and Literal Sets}
@ -96,7 +97,8 @@ using @racket[#:literals] or @racket[~literal].
'use-site]
[#:name expr-name (or/c identifier? string? symbol?) #f]
[#:macro macro-name (or/c identifier? string? symbol?) #f]
[#:context context (or/c syntax? #f) #, @elem{determined automatically}])]{
[#:context context (or/c syntax? #f) #, @elem{determined automatically}]
[#:phase phase exact-integer? (syntax-local-phase-level)])]{
Accepts an expression (@racket[expr]) and computes an attribute
@racket[c] that represents the expression wrapped with the contract
@ -156,16 +158,45 @@ syntax pair with an identifier in operator position; in either case,
that identifier is taken as the macro ultimately requesting the
contract wrapping.
See @secref{exprc} for an example.
The @racket[phase] argument must indicate the @tech[#:doc
refman]{phase level} at which the contracted expression will be
evaluated. Using the contracted expression at a different phase level
will cause a syntax error because it will contain introduced
references bound in the wrong phase. In particular:
@itemlist[
@item{Use the default value, @racket[(syntax-local-phase-level)], when
the contracted expression will be evaluated at the same phase as the
form currently being expanded. This is usually the case.}
@item{Use @racket[(add1 (syntax-local-phase-level))] in cases such as
the following: the contracted expression will be placed inside a
@racket[begin-for-syntax] form, used in the right-hand side of a
@racket[define-syntax] or @racket[let-syntax] form, or passed to
@racket[syntax-local-bind-syntaxes] or @racket[syntax-local-eval].}
]
Any phase level other than @racket[#f] (the @tech[#:doc refman]{label
phase level}) is allowed, but phases other than
@racket[(syntax-local-phase-level)] and @racket[(add1
(syntax-local-phase-level))] may only be used when in the dynamic
extent of a @tech[#:doc refman]{syntax transformer} or while a module
is being @tech[#:doc refman]{visit}ed (see
@racket[syntax-transforming?]), otherwise @racket[exn:fail:contract?]
is raised.
See @secref{exprc} for examples.
@bold{Important:} Make sure when using @racket[expr/c] to use the
@racket[c] attribute. The @racket[expr/c] syntax class does not change how
pattern variables are bound; it only computes an attribute that
represents the checked expression.
@history[#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword
@history[
#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword
argument and changed the default values and interpretation of the
@racket[#:positive] and @racket[#:negative] arguments.}]}
@racket[#:positive] and @racket[#:negative] arguments.}
#:changed "7.3.0.3" @elem{Added the @racket[#:phase] keyword argument.}]}
@section{Literal Sets}

135
pkgs/racket-test/tests/syntax/contract/phase.rkt Normal file
View File

@ -0,0 +1,135 @@
#lang racket/base
(require racket/match
rackunit
syntax/srcloc
syntax/strip-context)
(define blame-parties
(make-immutable-hash
(list (let ([stx #'here-syntax])
(cons #`(quote-syntax #,stx)
(source-location->string stx)))
(cons #''"here string" "here string")
(cons #'(module-path-index-join ''somewhere #f)
''somewhere)
(cons #''from-macro ''macro)
(cons #''use-site ''use)
(cons #''unknown "unknown"))))
(define-binary-check (check-blame-party=? actual expected)
(match actual
; module names can be uninterned symbols while they’re being expanded (to represent the fact that
; compile-time module paths can be completely unrelated from the one a module will eventually have
; once declared), but for our purposes we really do want to compare symbolic names
[`',mod-name
(equal? `',(string->symbol (symbol->string mod-name)) expected)]
[_
(equal? actual expected)]))
(define (elevate-phase stx #:phase-shift phase-shift)
(for/fold ([stx stx])
([i (in-range phase-shift)])
#`(begin-for-syntax #,stx)))
(for* ([definition-phase-shift (in-range 3)]
[expansion-phase-shift (in-range 3)]
[party-to-blame (in-list '(positive negative))]
[(blame-party-expr blame-party-val) (in-hash blame-parties)])
(with-check-info (['definition-phase-shift definition-phase-shift]
['expansion-phase-shift expansion-phase-shift]
['party-to-blame party-to-blame]
['blame-party-expr blame-party-expr]
['blame-party-val blame-party-val])
(parameterize ([current-namespace (make-base-namespace)])
; smuggle contract system predicates/accessors out of the relevant phase so that we can inspect
; the exception and the blame object inside
(define-values [exn:fail:contract:blame?
exn:fail:contract:blame-object
blame-positive
blame-original?
blame-swapped?]
(values #f #f #f #f #f))
(eval (strip-context
#`(module smuggler racket/base
(require racket/contract)
(#,(λ args (set!-values [exn:fail:contract:blame?
exn:fail:contract:blame-object
blame-positive
blame-original?
blame-swapped?]
(apply values args)))
exn:fail:contract:blame?
exn:fail:contract:blame-object
blame-positive
blame-original?
blame-swapped?))))
; define a macro that uses expr/c at some phase
(eval (strip-context
#`(module macro racket/base
(require
; imports for `begin-for-syntax`es in this module and in expansion
#,@(for/list ([phase (in-range 1 (+ definition-phase-shift
expansion-phase-shift))])
#`(for-meta #,phase (only-in racket/base begin-for-syntax)))
; imports for macro definition
(for-meta #,definition-phase-shift racket/base syntax/parse/define)
(for-meta #,(add1 definition-phase-shift) racket/base)
; imports for expressions in macro expansion
(for-meta #,(+ definition-phase-shift expansion-phase-shift)
(only-in racket/base
#%expression
exact-integer?)))
#,(elevate-phase
#:phase-shift definition-phase-shift
#`(begin
(provide integer-only)
(define-simple-macro (integer-only e)
#:declare e (expr/c #'exact-integer?
#:phase (+ (syntax-local-phase-level)
#,expansion-phase-shift)
#:arg? #,(eq? party-to-blame 'negative)
#,(match party-to-blame
['positive #'#:positive]
['negative #'#:negative])
#,blame-party-expr)
#,(elevate-phase
#:phase-shift expansion-phase-shift
#`(#%expression e.c))))))))
(for ([use-phase-shift (in-range 3)])
(with-check-info (['use-phase-shift use-phase-shift])
; use the macro at some phase and catch the exception
(define exn
(with-handlers ([(λ (exn) (exn:fail:contract:blame? exn)) values])
(eval (strip-context
#`(module use racket/base
(require
; imports for `begin-for-syntax`es in this module
#,@(for/list ([phase (in-range 1 (+ definition-phase-shift
use-phase-shift))])
#`(for-meta #,phase (only-in racket/base begin-for-syntax)))
; import for expression embedded in expansion (and value smuggling)
(for-meta #,(+ definition-phase-shift
expansion-phase-shift
use-phase-shift)
(only-in racket/base quote)
'smuggler)
; import for the macro
(for-meta #,use-phase-shift 'macro))
#,(elevate-phase
#:phase-shift (+ definition-phase-shift use-phase-shift)
#'(integer-only 'not-an-integer)))))
(when (zero? (+ definition-phase-shift expansion-phase-shift use-phase-shift))
(eval '(require 'use)))
#f))
; make sure the right party was blamed
(check-not-false exn "No exception raised")
(define blame (exn:fail:contract:blame-object exn))
(match party-to-blame
['positive (check-pred blame-original? blame)]
['negative (check-pred blame-swapped? blame)])
(check-blame-party=? (blame-positive blame) blame-party-val))))))

57
racket/collects/syntax/contract.rkt
View File

@ -1,10 +1,9 @@
#lang racket/base
(require racket/contract/base
(for-template racket/base
syntax/location)
syntax/srcloc
syntax/modcollapse
racket/syntax)
racket/syntax
syntax/location)
(provide/contract
[wrap-expr/c
@ -16,7 +15,8 @@
'from-macro 'use-site 'unknown)
#:name (or/c identifier? symbol? string? #f)
#:macro (or/c identifier? symbol? string? #f)
#:context (or/c syntax? #f))
#:context (or/c syntax? #f)
#:phase exact-integer?)
syntax?)])
(module runtime racket/base
@ -25,8 +25,11 @@
racket/contract/base
racket/contract/combinator
(only-in racket/contract/private/base
make-apply-contract))
(provide expr/contract
make-apply-contract)
syntax/location)
(provide (all-from-out racket/base
syntax/location)
expr/contract
relative-source)
(define (macro-expr/c arg? expr-name ctc0)
@ -42,7 +45,7 @@
#:late-neg-projection
(λ (blame)
(define blame* (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?))
(proj (blame-swap blame)))
(proj blame*))
#:list-contract? (list-contract? ctc)))
(define (macro-dep-expr/c arg? expr-name)
@ -114,7 +117,11 @@
[(symbol? r)
(list 'quote r)]
[else r])))
(require (for-template (submod "." runtime)))
;; Allow phase shift of 0 or 1 without needing to lift requires
(require (for-template (submod "." runtime))
;; for phase +1 uses, only need to instantiate, since we’ll shift
(only-in (submod "." runtime)))
(define (wrap-expr/c ctc-expr expr
#:arg? [arg? #t]
@ -122,7 +129,8 @@
#:negative [neg-source 'use-site]
#:name [expr-name #f]
#:macro [macro-name #f]
#:context [ctx (current-syntax-context)])
#:context [ctx (current-syntax-context)]
#:phase [phase (syntax-local-phase-level)])
(let* ([pos-source-expr
(get-source-expr pos-source
(if (identifier? macro-name) macro-name ctx))]
@ -141,13 +149,30 @@
[(x . _) (identifier? #'x) (syntax-e #'x)]
[x (identifier? #'x) (syntax-e #'x)]
[_ '?])]
[else '?])])
#`(expr/contract #,expr #,ctc-expr #,arg? '#,expr-name
[#,pos-source-expr
#,neg-source-expr
'#,macro-name
(quote-syntax #,expr)
#f])))
[else '?])]
[introduce (make-syntax-introducer)]
[phase-shift (- phase (syntax-local-phase-level))]
[shift+introduce (lambda (stx) (introduce (syntax-shift-phase-level stx phase-shift)))]
[unshift+introduce (lambda (stx) (introduce (syntax-shift-phase-level stx (- phase-shift))))]
[expr+ctc (shift+introduce
#`(expr/contract #,(unshift+introduce expr) #,(unshift+introduce ctc-expr)
'#,(and arg? #t) '#,expr-name
[#,pos-source-expr
#,neg-source-expr
'#,macro-name
(quote-syntax #,expr)
#f]))])
(cond
;; no need to lift for common phases, since we explicitly require them in this module
[(memq phase-shift '(0 1))
expr+ctc]
[else
(unless (syntax-transforming?)
(raise-arguments-error 'wrap-expr/c "not currently expanding"))
(define phased-require-spec
(introduce (datum->syntax #'here `(for-meta ,phase-shift ,(quote-module-path runtime)))))
(syntax-local-introduce (syntax-local-lift-require (syntax-local-introduce phased-require-spec)
(syntax-local-introduce expr+ctc)))])))
(define (get-source-expr source ctx)
(cond [(eq? source 'use-site)

9
racket/collects/syntax/parse/experimental/contract.rkt
View File

@ -15,7 +15,8 @@
#:negative [neg-blame 'use-site]
#:macro [macro-name #f]
#:name [expr-name not-given]
#:context [ctx #f])
#:context [ctx #f]
#:phase [phase (syntax-local-phase-level)])
#:attributes (c)
#:commit
(pattern y:expr
@ -29,7 +30,8 @@
this-role
expr-name)
#:macro macro-name
#:context (or ctx (this-context-syntax)))))
#:context (or ctx (this-context-syntax))
#:phase phase)))
(provide-syntax-class/contract
[expr/c (syntax-class/c (syntax?)
@ -40,4 +42,5 @@
'from-macro 'use-site 'unknown)
#:name (or/c identifier? string? symbol? #f)
#:macro (or/c identifier? string? symbol? #f)
#:context (or/c syntax? #f)))])
#:context (or/c syntax? #f)
#:phase exact-integer?))])