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

Moved the contents of unstable/cce/syntax to multiple other modules:

Browse Source 
unstable/syntax, unstable/contract, and unstable/planet-syntax.
This commit is contained in:
Carl Eastlund 2010-05-30 02:44:10 -04:00
parent 904f80cd44
commit ce85a96978
23 changed files with 709 additions and 1115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/tests/unstable/contract.rkt
View File

@ -19,6 +19,33 @@
(test-ok (with/c truth/c #t))
(test-ok (with/c truth/c #f))
(test-ok (with/c truth/c '(x)))))
(test-suite "Syntax Object Contracts"
(test-suite "syntax-datum/c"
(test-ok (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((0 1 2) () (3 4) (5))))
(test-bad (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((x y z))))
(test-bad (with/c (syntax-datum/c string?) "xyz")))
(test-suite "syntax-listof/c"
(test-ok (with/c (syntax-listof/c identifier?) #'(a b c)))
(test-bad (with/c (syntax-listof/c identifier?) #'(1 2 3)))
(test-bad (with/c (syntax-listof/c identifier?) #'(a b . c)))
(test-bad (with/c (syntax-listof/c identifier?) (list #'a #'b #'c))))
(test-suite "syntax-list/c"
(test-ok (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b")))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" #:c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a b)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" . c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
'(#'a #'"b")))))
(test-suite "Higher Order Contracts"
(test-suite "thunk/c"
(test-ok ([with/c thunk/c gensym]))

55
collects/tests/unstable/planet-syntax.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang racket
(require mzlib/etc
planet/util
rackunit
rackunit/text-ui
unstable/planet-syntax
"helpers.rkt")
(define here
(datum->syntax
#f 'here
(list (build-path (this-expression-source-directory)
(this-expression-file-name))
1 1 1 1)))
(run-tests
(test-suite "planet-syntax.ss"
(test-suite "syntax-source-planet-package"
(test-case "fail"
(check-equal? (syntax-source-planet-package (datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-owner"
(test-case "fail"
(check-equal? (syntax-source-planet-package-owner
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-name"
(test-case "fail"
(check-equal? (syntax-source-planet-package-name
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-major"
(test-case "fail"
(check-equal? (syntax-source-planet-package-major
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-minor"
(test-case "fail"
(check-equal? (syntax-source-planet-package-minor
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-symbol"
(test-case "fail"
(check-equal? (syntax-source-planet-package-minor
(datum->syntax #f 'fail))
#f)))
(test-suite "make-planet-path")))

94
collects/tests/unstable/syntax.rkt Normal file
View File

@ -0,0 +1,94 @@
#lang racket
(require mzlib/etc
rackunit
rackunit/text-ui
unstable/syntax
"helpers.rkt")
(define here
(datum->syntax
#f 'here
(list (build-path (this-expression-source-directory)
(this-expression-file-name))
1 1 1 1)))
(run-tests
(test-suite "syntax.ss"
(test-suite "Syntax Lists"
(test-suite "syntax-list"
(test
(check-equal?
(with-syntax ([([x ...] ...) #'([1 2] [3] [4 5 6])])
(map syntax->datum (syntax-list x ... ...)))
(list 1 2 3 4 5 6))))
(test-suite "syntax-map"
(test-case "identifiers to symbols"
(check-equal? (syntax-map syntax-e #'(a b c)) '(a b c)))))
(test-suite "Syntax Conversions"
(test-suite "to-syntax"
(test-case "symbol + context = identifier"
(check bound-identifier=?
(to-syntax #:stx #'context 'id)
#'id)))
(test-suite "to-datum"
(test-case "syntax"
(check-equal? (to-datum #'((a b) () (c)))
'((a b) () (c))))
(test-case "non-syntax"
(check-equal? (to-datum '((a b) () (c)))
'((a b) () (c))))
(test-case "nested syntax"
(let* ([stx-ab #'(a b)]
[stx-null #'()]
[stx-c #'(c)])
(check-equal? (to-datum (list stx-ab stx-null stx-c))
(list stx-ab stx-null stx-c))))))
(test-suite "Syntax Source Locations"
(test-suite "syntax-source-file-name"
(test-case "here"
(check-equal? (syntax-source-file-name here)
(this-expression-file-name)))
(test-case "fail"
(check-equal? (syntax-source-file-name (datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-directory"
(test-case "here"
(check-equal? (syntax-source-directory here)
(this-expression-source-directory)))
(test-case "fail"
(check-equal? (syntax-source-directory (datum->syntax #f 'fail))
#f))))
(test-suite "Transformers"
(test-suite "redirect-transformer"
(test (check-equal?
(syntax->datum ((redirect-transformer #'x) #'y))
'x))
(test (check-equal?
(syntax->datum ((redirect-transformer #'x) #'(y z)))
'(x z))))
(test-suite "head-expand")
(test-suite "trampoline-transformer")
(test-suite "quote-transformer"))
(test-suite "Pattern Bindings"
(test-suite "with-syntax*"
(test-case "identifier"
(check bound-identifier=?
(with-syntax* ([a #'id] [b #'a]) #'b)
#'id))))))

6
collects/unstable/cce/define.ss
View File

@ -3,7 +3,7 @@
(require "private/define-core.ss"
(for-syntax scheme/match
syntax/kerncase
"syntax.ss"))
unstable/syntax))
(provide
@ -31,7 +31,7 @@
(syntax-local-lift-module-end-declaration
(syntax/loc stx (begin e ...)))
(syntax/loc stx (begin)))]
[ctx (syntax-error stx
[ctx (wrong-syntax stx
"can only be used in module context; got: ~s"
ctx)])]))
@ -128,7 +128,7 @@
(begin
(define-syntax (macro stx*) (begin e (syntax/loc stx* (begin))))
(macro)))]
['module-begin (syntax-error stx "cannot be used as module body")])]))
['module-begin (wrong-syntax stx "cannot be used as module body")])]))
(define-syntax (in-phase1/pass2 stx)
(syntax-case stx []

4
collects/unstable/cce/planet.ss
View File

@ -1,7 +1,7 @@
#lang scheme
(require (for-syntax "syntax.ss")
"syntax.ss"
(require (for-syntax unstable/planet-syntax)
unstable/planet-syntax
"require-provide.ss")
(define-syntax (this-package-version-symbol stx)

20
collects/unstable/cce/private/define-core.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require (for-syntax scheme/base scheme/list "syntax-core.ss"))
(require (for-syntax scheme/base scheme/list unstable/syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -32,12 +32,12 @@
[(_ def [name ...] expr)
(let* ([ids (syntax->list #'(name ...))])
(for ([bad (in-list ids)] #:when (not (identifier? bad)))
(syntax-error bad "expected an identifier"))
(wrong-syntax bad "expected an identifier"))
(let*-values ([(bound unbound) (partition identifier-binding ids)])
(cond
[(null? bound) (syntax/loc stx (def [name ...] expr))]
[(null? unbound) (syntax/loc stx (def [] (values)))]
[else (syntax-error
[else (wrong-syntax
stx
"conflicting definitions for ~s; none for ~s"
(map syntax-e bound)
@ -52,17 +52,3 @@
(define-many-if-unbound define-syntaxes [name ...] expr))
(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Trampoline Expansion
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide #%trampoline)
(define-syntax (#%trampoline stx)
(syntax-case stx ()
[(_ thunk)
(procedure? (syntax-e #'thunk))
(#%app (syntax-e #'thunk))]))

160
collects/unstable/cce/private/syntax-core.ss
View File

@ -1,160 +0,0 @@
#lang scheme/base
(require scheme/contract
scheme/match
unstable/text
(only-in unstable/syntax with-syntax*)
(for-syntax scheme/base))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Source Locations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide src-known? src->srcloc src->list src->vector src->syntax)
(define srcloc->list
(match-lambda
[(struct srcloc [src line col pos span])
(list src line col pos span)]))
(define srcloc->vector
(match-lambda
[(struct srcloc [src line col pos span])
(vector src line col pos span)]))
(define (srcloc->syntax loc [v null])
(datum->syntax #f v (srcloc->list loc)))
(define (src->srcloc . locs) (combine-srclocs (map convert-loc locs)))
(define src->list (compose srcloc->list src->srcloc))
(define src->vector (compose srcloc->vector src->srcloc))
(define src->syntax (compose srcloc->syntax src->srcloc))
(define (src-known? x)
(not (equal? (convert-loc x) (convert-loc #f))))
(define convert-loc
(match-lambda
[(? srcloc? loc) loc]
[(or (list src line col pos span)
(vector src line col pos span)
(and #f src line col pos span)
(and (? syntax?)
(app syntax-source src)
(app syntax-line line)
(app syntax-column col)
(app syntax-position pos)
(app syntax-span span)))
(make-srcloc src line col pos span)]))
(define combine-srclocs
(match-lambda
;; Two locations with matching source
[(list (struct srcloc [src line1 col1 pos1 span1])
(struct srcloc [src line2 col2 pos2 span2])
locs ...)
(let* ([line (and line1 line2 (min line1 line2))]
[col (and line col1 col2
(cond [(< line1 line2) col1]
[(= line1 line2) (min col1 col2)]
[(> line1 line2) col2]))]
[pos (and pos1 pos2 (min pos1 pos2))]
[span (and pos span1 span2
(- (max (+ pos1 span1) (+ pos2 span2)) pos))])
(combine-srclocs (cons (make-srcloc src line col pos span) locs)))]
;; One location
[(list loc) loc]
;; No locations, or mismatched sources
[_ (make-srcloc #f #f #f #f #f)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Conversions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide syntax-map to-syntax to-datum)
(define (syntax-map f stx)
(map f (syntax->list stx)))
(define (to-syntax datum
#:stx [stx #f]
#:src [src stx]
#:ctxt [ctxt stx]
#:prop [prop stx]
#:cert [cert stx])
(datum->syntax ctxt
datum
(if (srcloc? src) (srcloc->list src) src)
prop
cert))
(define (to-datum v)
(if (syntax? v)
(syntax->datum v)
v))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Pattern Bindings
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide with-syntax* syntax-list)
(define-syntax-rule (syntax-list template ...)
(syntax->list (syntax (template ...))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Errors
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide current-syntax syntax-error)
(define current-syntax (make-parameter #f))
(define (syntax-error #:name [name #f] stx msg . args)
(let* ([cur (current-syntax)]
[one (if cur cur stx)]
[two (if cur stx #f)]
[sym (if name (text->symbol name) #f)]
[str (apply format msg args)])
(raise-syntax-error sym str one two)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Contracts
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide syntax-datum/c syntax-listof/c syntax-list/c)
(define (syntax-datum/c datum)
(let* ([datum/c (coerce-contract datum datum)])
(flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate datum/c)
(syntax->datum v)))))))
(define (syntax-listof/c elem)
(let* ([elem/c (coerce-contract elem elem)])
(flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (listof elem/c))
(syntax->list v)))))))
(define (syntax-list/c . elems)
(let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
(flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (apply list/c elem/cs))
(syntax->list v)))))))

1
collects/unstable/cce/reference/manual.scrbl
View File

@ -12,7 +12,6 @@
@include-section["set.scrbl"]
@include-section["syntax.scrbl"]
@include-section["define.scrbl"]
@include-section["require-provide.scrbl"]

2
collects/unstable/cce/reference/planet.scrbl
View File

@ -19,7 +19,7 @@ binding described below, it provides @scheme[define-planet-package] and
@scheme[syntax-source-planet-package-major],
@scheme[syntax-source-planet-package-minor], and
@scheme[syntax-source-planet-package-symbol] from
@schememodname[unstable/cce/syntax].
@schememodname[unstable/planet-syntax].
@defform*[[
(this-package-version-symbol)

387
collects/unstable/cce/reference/syntax.scrbl
View File

@ -1,387 +0,0 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
"../scribble.ss"
"eval.ss")
@(require (for-label scheme unstable/cce/syntax))
@title[#:style 'quiet #:tag "cce-syntax"]{Syntax Objects}
@defmodule[unstable/cce/syntax]
This module provides tools for macro transformers.
@section{Contracts}
@defproc[(syntax-datum/c [datum/c any/c]) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->datum stx)]
satisfies @scheme[datum/c].
}
@defproc[(syntax-listof/c [elem/c any/c]) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
satisfies @scheme[(listof elem/c)].
}
@defproc[(syntax-list/c [elem/c any/c] ...) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
satisfies @scheme[(list/c elem/c ...)].
}
@section{Syntax Lists}
@defform[(syntax-list template ...)]{
This form constructs a list of syntax objects based on the given templates. It
is equivalent to @scheme[(syntax->list (syntax (template ...)))].
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(with-syntax ([(x ...) (syntax (1 2 3))]) (syntax-list x ...))
]
}
@defproc[(syntax-map [f (-> syntax? A)] [stx syntax?]) (listof A)]{
Performs @scheme[(map f (syntax->list stx))].
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(syntax-map syntax-e #'(a (b c) d))
]
}
@section{Syntax Conversions}
@defproc[(to-syntax [datum any/c]
[#:stx stx (or/c false/c syntax?) #f]
[#:src src src/c stx]
[#:ctxt ctxt (or/c false/c syntax?) stx]
[#:prop prop (or/c false/c syntax?) stx]
[#:cert cert (or/c false/c syntax?) stx])
syntax?]{
A wrapper for @scheme[datum->syntax] with keyword arguments.
The "master" keyword @scheme[#:stx] sets all attributes from a single syntax
object, defaulting to @scheme[#f] for unadorned syntax objects.
The individual keywords @scheme[#:src], @scheme[#:ctxt], @scheme[#:prop], and
@scheme[#:cert] override @scheme[#:stx] for individual syntax object
attributes. They control source src information, lexical context
information, syntax object properties, and syntax certificates, respectively.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(define blank-stx (to-syntax 'car))
blank-stx
(syntax-e blank-stx)
(free-identifier=? blank-stx #'car)
(define full-stx (to-syntax 'car #:stx #'here))
full-stx
(syntax-e full-stx)
(free-identifier=? full-stx #'car)
(define partial-stx (to-syntax 'car #:ctxt #'here))
partial-stx
(syntax-e partial-stx)
(free-identifier=? partial-stx #'car)
]
}
@defproc[(to-datum [x any/c]) (not/c syntax?)]{
A wrapper for @scheme[syntax->datum]. Produces @scheme[(syntax->datum x)] if
@scheme[x] is a syntax object and @scheme[x] otherwise.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(to-datum #'(a b c))
(to-datum (list #'a #'b #'c))
]
}
@section{Source Locations [Deprecated]}
@subsection{Source Location Representations}
@defthing[src/c flat-contract?]{
This contract recognizes various representations of source locations, including
@scheme[srcloc] structures and those accepted by @scheme[datum->syntax]: syntax
objects, source location lists, source location vectors, and @scheme[#f].
}
@deftogether[(
@defproc[(src->srcloc [loc src/c] ...) srcloc?]
@defproc[(src->syntax [loc src/c] ...) syntax?]
@defproc[(src->list [loc src/c] ...)
(list/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f))]
@defproc[(src->vector [loc src/c] ...)
(vector/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f))]
)]{
These functions combine multiple source locations and convert them to a specific
format. If all provided source locations come from the same source, the result
is a source location from the same source that spans all the lines, columns, and
positions included in the originals. If no source locations are provided, or
locations from different sources are provided, the result is a source location
with no information (@scheme[#f] for source, line, column, position, and span).
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(src->srcloc (datum->syntax #f null (list 'source 2 3 4 5)))
(src->syntax (make-srcloc 'source 2 3 4 5))
(src->list (list 'source 2 3 4 5) (vector 'source 6 7 8 9))
(src->vector)
]
}
@defproc[(src-known? [loc src/c]) boolean?]{
Reports whether @scheme[loc] has any non-@scheme[#f] fields.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(src-known? (list #f #f #f #f #f))
(src-known? (list 'source #f #f #f #f))
(src-known? (list 'source 1 2 3 4))
]
}
@subsection{Syntax Object Source Locations}
@deftogether[(
@defproc[(syntax-source-directory [stx syntax?]) (or/c path? #f)]
@defproc[(syntax-source-file-name [stx syntax?]) (or/c path? #f)]
)]{
These produce the directory and file name, respectively, of the path with which
@scheme[stx] is associated, or @scheme[#f] if @scheme[stx] is not associated
with a path.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(define loc
(list (build-path "/tmp" "dir" "somewhere.ss")
#f #f #f #f))
(define stx1 (datum->syntax #f 'somewhere loc))
(syntax-source-directory stx1)
(syntax-source-file-name stx1)
(define stx2 (datum->syntax #f 'nowhere #f))
(syntax-source-directory stx2)
(syntax-source-directory stx2)
]
}
@deftogether[(
@defproc[(syntax-source-planet-package [stx syntax?])
(or/c (list/c string?
string?
exact-nonnegative-integer?
exact-nonnegative-integer?)
#f)]
@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-major [stx syntax?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(syntax-source-planet-package-minor [stx syntax?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(syntax-source-planet-package-symbol
[stx syntax?]
[text (or/c text? #f) #f])
(or/c symbol? #f)]
)]{
These functions extract the planet package with which @scheme[stx] is
associated, if any, based on its source location information and the currently
installed set of planet packages. They produce, respectively, the planet
package s-expression, its owner, name, major version number, minor version
number, or a symbol corresponding to a @scheme[planet] module path. They each
produce @scheme[#f] if @scheme[stx] is not associated with a planet package.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(define loc
(list (build-path (current-directory) "file.ss")
#f #f #f #f))
(define stx (datum->syntax #f 'stx loc))
(syntax-source-planet-package stx)
(syntax-source-planet-package-owner stx)
(syntax-source-planet-package-name stx)
(syntax-source-planet-package-major stx)
(syntax-source-planet-package-minor stx)
(syntax-source-planet-package-symbol stx)
(syntax-source-planet-package-symbol stx "there")
]
}
@defproc[(make-planet-path [stx syntax?] [id (or/c identifier? #f)]) syntax?]{
Constructs a syntax object representing a require spec for the planet package
from which @scheme[stx] arises, with suffix @scheme[id] (if any).
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(define loc
(list (build-path (current-directory) "file.ss")
#f #f #f #f))
(define stx (datum->syntax #f 'stx loc))
(make-planet-path stx #f)
(make-planet-path stx #'there)
]
}
@section{Macro Transformers}
@defproc[(redirect-transformer [id identifier?]) (-> syntax? syntax?)]{
Constructs a function that behaves like a rename transformer; it does not
cooperate with @scheme[syntax-local-value] like a rename transformer does, but
unlike a rename transformer it may be used as a function to transform a syntax
object referring to one identifier into a syntax object referring to another.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
((redirect-transformer #'x) #'a)
((redirect-transformer #'y) #'(a b c))
]
}
@defproc[(head-expand [stx syntax?] [stop-list (listof identifier?)]) syntax?]{
This function performs head expansion on @scheme[stx]. In other words, it uses
@scheme[local-expand] to expand @scheme[stx] until its head identifier is a core
form (a member of @scheme[(full-kernel-form-identifier-list)]) or a member of
@scheme[stop-list], or until it can not be expanded further (e.g. due to error).
It is equivalent to @scheme[(local-expand stx (syntax-local-context) (append
stop-ids (full-kernel-form-identifier-list) #f))].
}
@defproc[(full-kernel-form-identifier-list) (listof identifier?)]{
This function produces the full list of identifiers that may be found in fully
expanded code produced by @scheme[expand], @scheme[local-expand], and related
functions. It is similar to @scheme[kernel-form-identifier-list], except that
in prior versions of PLT Scheme that excluded module top-level forms from the
list, this function includes them.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(full-kernel-form-identifier-list)
]
}
@defproc[(trampoline-transformer
[f (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)])
(-> syntax? syntax?)]{
Produces a transformer that can emit multiple results during macro expansion, to
be spliced together via @scheme[begin]. This can be useful for compound
expansion that relies on transformer definitions, as well as on expansion state
that is difficult to marshall.
Specifically, @scheme[f] is invoked with three arguments. The first is the
function used to emit intermediate results (other than the last one). The
second applies the @tech[#:doc '(lib
"scribblings/reference/reference.scrbl")]{syntax mark} used for the entire
expansion; @scheme[syntax-local-introduce] will not be reliable during this
process. The third is the syntax object to expand.
@defexamples[
#:eval (evaluator '(for-syntax unstable/cce/syntax))
(define-syntax magic-begin
(trampoline-transformer
(lambda (emit intro stx)
(syntax-case stx ()
[(_ term ...)
(let loop ([terms (syntax->list #'(term ...))])
(cond
[(null? terms) #'(begin)]
[(null? (cdr terms)) (car terms)]
[else
(printf "Presto: ~s!\n"
(syntax->datum (car terms)))
(emit (car terms))
(loop (cdr terms))]))]))))
(magic-begin
(define x 1)
(define y 2)
(+ x y))
]
}
@defproc[(quote-transformer [x any/c]) syntax?]{
Produces a syntax object representing an expression that reconstructs @scheme[x]
when executed, including faithfully reconstructing any syntax objects contained
in @scheme[x]. Note that @scheme[quote] normally converts syntax objects to
non-syntax data, and @scheme[quote-syntax] does the opposite.
@defexamples[
#:eval (evaluator '(for-syntax unstable/cce/syntax))
(define-for-syntax x (list 1 #'(2 3) 4))
(define-syntax (the-many-faces-of-x stx)
(with-syntax ([x x] [qx (quote-transformer x)])
#'(list (quote x)
(quote-syntax x)
qx)))
(the-many-faces-of-x)
]
}
@section{Syntax Errors}
@defthing[current-syntax (parameter/c (or/c syntax? false/c))]{
A parameter that may be used to store the current syntax object being
transformed. It is not used by the expander; you have to assign to it yourself.
This parameter is used by @scheme[syntax-error], below. It defaults to
@scheme[#f].
}
@defproc[(syntax-error [stx syntax?] [fmt string?] [arg any/c] ...) none/c]{
Raises a syntax error based on the locations of @scheme[(current-syntax)] and
@scheme[stx], with @scheme[(format fmt arg ...)] as its message.
@defexamples[
#:eval (evaluator 'unstable/cce/syntax)
(define stx #'(a b c))
(parameterize ([current-syntax #f])
(syntax-error stx "~s location" 'general))
(parameterize ([current-syntax stx])
(syntax-error (car (syntax-e stx)) "~s location" 'specific))
]
}
@section{Pattern Bindings}
This package re-exports @scheme[with-syntax*] from
@schememodname[unstable/syntax].

2
collects/unstable/cce/require-provide.ss
View File

@ -4,7 +4,7 @@
scheme/require-transform
scheme/provide-transform
syntax/parse
"syntax.ss")
unstable/planet-syntax)
"define.ss")
(define-syntax (define-planet-package stx)

2
collects/unstable/cce/scribble.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scribble/manual unstable/sandbox "planet.ss"
(for-syntax scheme/base "syntax.ss"))
(for-syntax scheme/base unstable/planet-syntax))
(define-for-syntax (make-planet-paths stx ids)
(map (lambda (id) (make-planet-path stx id)) (syntax->list ids)))

278
collects/unstable/cce/syntax.ss
View File

@ -1,278 +0,0 @@
#lang scheme/base
(require scheme/path
scheme/match
scheme/contract
scheme/vector
scheme/list
syntax/stx
syntax/kerncase
setup/main-collects
planet/planet-archives
unstable/contract
unstable/text
(for-template scheme/base)
(for-syntax scheme/base)
(for-label scheme)
"private/syntax-core.ss"
"private/define-core.ss"
(for-template "private/define-core.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; SYNTAX OBJECTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Locations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (syntax-source-directory stx)
(match (syntax-source stx)
[(? path-string? source)
(let-values ([(base file dir?) (split-path source)])
(and (path? base)
(path->complete-path base
(or (current-load-relative-directory)
(current-directory)))))]
[_ #f]))
(define (syntax-source-file-name stx)
(match (syntax-source stx)
[(? path-string? f)
(let-values ([(base file dir?) (split-path f)]) file)]
[_ #f]))
(define (syntax-source-planet-package stx)
(let* ([dir (syntax-source-directory stx)])
(and dir (this-package-version/proc dir))))
(define (syntax-source-planet-package-owner stx)
(let* ([pkg (syntax-source-planet-package stx)])
(and pkg (pd->owner pkg))))
(define (syntax-source-planet-package-name stx)
(let* ([pkg (syntax-source-planet-package stx)])
(and pkg (pd->name pkg))))
(define (syntax-source-planet-package-major stx)
(let* ([pkg (syntax-source-planet-package stx)])
(and pkg (pd->maj pkg))))
(define (syntax-source-planet-package-minor stx)
(let* ([pkg (syntax-source-planet-package stx)])
(and pkg (pd->min pkg))))
(define (syntax-source-planet-package-symbol stx [suffix #f])
(match (syntax-source-planet-package stx)
[(list owner name major minor)
(string->symbol
(format "~a/~a:~a:~a~a"
owner
(regexp-replace "\\.plt$" name "")
major
minor
(if suffix (text->string "/" suffix) "")))]
[#f #f]))
(define (make-planet-path stx id/f)
(datum->syntax
stx
(list #'planet (syntax-source-planet-package-symbol stx id/f))
(or id/f stx)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Transformer patterns:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((redirect-transformer id) stx)
(cond
[(identifier? stx) id]
[(and (stx-pair? stx) (identifier? (stx-car stx)))
(to-syntax (cons id (stx-cdr stx)) #:stx stx)]
[else
(syntax-error
stx
"expected an identifier (alone or in application position); cannot redirect to ~a"
(syntax-e id))]))
(define (head-expand stx [stop-ids null])
(local-expand stx
(syntax-local-context)
(append stop-ids (full-kernel-form-identifier-list))
#f))
(define-syntax-if-unbound quote-syntax/prune
(make-rename-transformer #'quote-syntax))
(define (full-kernel-form-identifier-list)
(remove-duplicates
(list* (quote-syntax/prune #%require)
(quote-syntax/prune #%provide)
(quote-syntax/prune module)
(quote-syntax/prune #%plain-module-begin)
(kernel-form-identifier-list))
free-identifier=?))
(define (quote-transformer datum)
#`(quasiquote
#,(let loop ([datum datum])
(cond
[(syntax? datum) #`(unquote (quote-syntax #,datum))]
[(pair? datum) #`#,(cons (loop (car datum)) (loop (cdr datum)))]
[(vector? datum) #`#,(vector-map loop datum)]
[(box? datum) #`#,(box (loop (unbox datum)))]
[(hash? datum)
#`#,((cond [(hash-eqv? datum) make-immutable-hasheqv]
[(hash-eq? datum) make-immutable-hasheq]
[else make-immutable-hash])
(hash-map datum (lambda (k v) (cons k (loop v)))))]
[(prefab-struct-key datum) =>
(lambda (key)
#`#,(apply make-prefab-struct
key
(for/list ([i (in-vector (struct->vector datum) 1)])
(loop i))))]
[else #`#,datum]))))
(define trampoline-prompt-tag
(make-continuation-prompt-tag 'trampoline))
(define ((trampoline-transformer transform) stx)
(define intro (make-syntax-introducer))
(define (body)
(syntax-local-introduce
(intro
(transform (trampoline-evaluator intro)
intro
(intro (syntax-local-introduce stx))))))
(call-with-continuation-prompt body trampoline-prompt-tag))
(define ((trampoline-evaluator intro) stx)
(define ((wrap continue))
(call-with-continuation-prompt continue trampoline-prompt-tag))
(define ((expander continue))
#`(begin #,(syntax-local-introduce (intro stx))
(#%trampoline #,(wrap continue))))
(define (body continue)
(abort-current-continuation trampoline-prompt-tag (expander continue)))
(call-with-composable-continuation body trampoline-prompt-tag)
(void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; From planet/util:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (this-package-version/proc srcdir)
(let* ([package-roots (get-all-planet-packages)]
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
package-roots)])
(and thepkg (archive-retval->simple-retval thepkg))))
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (lambda (x) (if (pred x) x #f)))
;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
(let* ([nsrcdir (normalize-path srcdir)]
[nsuperdir (normalize-path (car alleged-superdir-pkg))]
[nsrclist (explode-path nsrcdir)]
[nsuperlist (explode-path nsuperdir)])
(list-prefix? nsuperlist nsrclist)))
(define (list-prefix? sup sub)
(let loop ([sub sub]
[sup sup])
(cond
[(null? sup) #t]
[(equal? (car sup) (car sub))
(loop (cdr sub) (cdr sup))]
[else #f])))
(define (archive-retval->simple-retval p)
(list-refs p '(1 2 4 5)))
(define-values (pd->owner pd->name pd->maj pd->min)
(apply values (map (lambda (n) (lambda (l) (list-ref l n))) '(0 1 2 3))))
(define (list-refs p ns)
(map (lambda (n) (list-ref p n)) ns))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; EXPORTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define stx/f (or/c syntax? #f))
(define nat/f (or/c nat/c #f))
(define pos/f (or/c pos/c #f))
(define src-list/c (list/c any/c pos/f nat/f pos/f nat/f))
(define src-vector/c (vector/c any/c pos/f nat/f pos/f nat/f))
(define src/c
(or/c srcloc?
syntax?
src-list/c
src-vector/c
#f))
(provide/contract
[src/c flat-contract?]
[src-known? (-> src/c boolean?)]
[src->srcloc (->* [] [] #:rest (listof src/c) srcloc?)]
[src->list (->* [] [] #:rest (listof src/c) src-list/c)]
[src->vector (->* [] [] #:rest (listof src/c) src-vector/c)]
[src->syntax (->* [] [] #:rest (listof src/c) syntax?)]
[syntax-datum/c (-> flat-contract? flat-contract?)]
[syntax-listof/c (-> flat-contract? flat-contract?)]
[syntax-list/c
(->* [] [] #:rest (listof flat-contract?) flat-contract?)]
[syntax-map (-> (-> syntax? any/c) (syntax-listof/c any/c) (listof any/c))]
[to-syntax
(->* [any/c]
[#:stx stx/f #:src src/c #:ctxt stx/f #:prop stx/f #:cert stx/f]
syntax?)]
[to-datum (-> any/c (not/c syntax?))]
[syntax-source-file-name (-> syntax? (or/c path? #f))]
[syntax-source-directory (-> syntax? (or/c path? #f))]
[syntax-source-planet-package
(-> syntax? (or/c (list/c string? string? nat/c nat/c) #f))]
[syntax-source-planet-package-owner (-> syntax? (or/c string? #f))]
[syntax-source-planet-package-name (-> syntax? (or/c string? #f))]
[syntax-source-planet-package-major (-> syntax? (or/c nat/c #f))]
[syntax-source-planet-package-minor (-> syntax? (or/c nat/c #f))]
[syntax-source-planet-package-symbol
(->* [syntax?] [(or/c text? #f)] (or/c symbol? #f))]
[make-planet-path (-> syntax? (or/c identifier? #f) syntax?)]
[trampoline-transformer
(-> (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)
(-> syntax? syntax?))]
[quote-transformer (-> any/c syntax?)]
[redirect-transformer (-> identifier? (-> syntax? syntax?))]
[head-expand (->* [syntax?] [(listof identifier?)] syntax?)]
[full-kernel-form-identifier-list (-> (listof identifier?))]
[current-syntax (parameter/c (or/c syntax? false/c))]
[syntax-error (->* [syntax? string?]
[#:name (or/c text? #f)]
#:rest list?
none/c)])
(provide with-syntax* syntax-list)

6
collects/unstable/cce/test/test-main.ss
View File

@ -6,8 +6,7 @@
"test-planet.ss"
"test-require-provide.ss"
"test-scribble.ss"
"test-set.ss"
"test-syntax.ss")
"test-set.ss")
(run-tests
(test-suite "scheme.plt"
@ -16,5 +15,4 @@
planet-suite
require-provide-suite
scribble-suite
set-suite
syntax-suite))
set-suite))

256
collects/unstable/cce/test/test-syntax.ss
View File

@ -1,256 +0,0 @@
#lang scheme
(require mzlib/etc
planet/util
"checks.ss"
"../syntax.ss")
(provide syntax-suite)
(define here
(datum->syntax
#f
'here
(list (build-path (this-expression-source-directory)
(this-expression-file-name))
1 1 1 1)))
(define syntax-suite
(test-suite "syntax.ss"
(test-suite "Contracts"
(test-suite "syntax-datum/c"
(test-ok (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((0 1 2) () (3 4) (5))))
(test-bad (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((x y z))))
(test-bad (with/c (syntax-datum/c string?) "xyz")))
(test-suite "syntax-listof/c"
(test-ok (with/c (syntax-listof/c identifier?) #'(a b c)))
(test-bad (with/c (syntax-listof/c identifier?) #'(1 2 3)))
(test-bad (with/c (syntax-listof/c identifier?) #'(a b . c)))
(test-bad (with/c (syntax-listof/c identifier?) (list #'a #'b #'c))))
(test-suite "syntax-list/c"
(test-ok (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b")))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" #:c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a b)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" . c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
'(#'a #'"b")))))
(test-suite "Source Location Representations"
(test-suite "src/c"
(test-ok (with/c src/c #f))
(test-ok (with/c src/c (make-srcloc 'source 1 0 1 0)))
(test-ok (with/c src/c #'here))
(test-ok (with/c src/c (list 'source 1 0 1 0)))
(test-bad (with/c src/c (list 'source 1 0 0 1)))
(test-bad (with/c src/c (list 'source 0 0 0 0)))
(test-ok (with/c src/c (vector 'source 1 0 1 0)))
(test-bad (with/c src/c (vector 'source 1 0 0 1)))
(test-bad (with/c src/c (vector 'source 0 0 0 0)))
(test-bad (with/c src/c 'symbol)))
(test-suite "src->srcloc"
(test-ok (check-equal? (src->srcloc #f) (make-srcloc #f #f #f #f #f)))
(test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0))
(make-srcloc 'source 1 0 1 0)))
(test-ok (check-equal? (src->srcloc (datum->syntax #f 'here #f))
;; Note known bug w/ syntax-span:
(make-srcloc #f #f #f #f 0)))
(test-ok (check-equal? (src->srcloc (list 'source 1 0 1 0))
(make-srcloc 'source 1 0 1 0)))
(test-ok (check-equal? (src->srcloc (vector 'source 1 0 1 0))
(make-srcloc 'source 1 0 1 0)))
(test-ok (check-equal? (src->srcloc) (make-srcloc #f #f #f #f #f)))
(test-ok (check-equal? (src->srcloc (make-srcloc 'one 1 0 1 0)
(make-srcloc 'two 1 0 1 0))
(make-srcloc #f #f #f #f #f)))
(test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0)
(make-srcloc 'source 2 1 2 1))
(make-srcloc 'source 1 0 1 2))))
(test-suite "src->list"
(test-ok (check-equal? (src->list #f) (list #f #f #f #f #f)))
(test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0))
(list 'source 1 0 1 0)))
(test-ok (check-equal? (src->list (datum->syntax #f 'here #f))
;; Note known bug w/ syntax-span:
(list #f #f #f #f 0)))
(test-ok (check-equal? (src->list (list 'source 1 0 1 0))
(list 'source 1 0 1 0)))
(test-ok (check-equal? (src->list (vector 'source 1 0 1 0))
(list 'source 1 0 1 0)))
(test-ok (check-equal? (src->list) (list #f #f #f #f #f)))
(test-ok (check-equal? (src->list (make-srcloc 'one 1 0 1 0)
(make-srcloc 'two 1 0 1 0))
(list #f #f #f #f #f)))
(test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0)
(make-srcloc 'source 2 1 2 1))
(list 'source 1 0 1 2))))
(test-suite "src->vector"
(test-ok (check-equal? (src->vector #f) (vector #f #f #f #f #f)))
(test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0))
(vector 'source 1 0 1 0)))
(test-ok (check-equal? (src->vector (datum->syntax #f 'here #f))
;; Note known bug w/ syntax-span:
(vector #f #f #f #f 0)))
(test-ok (check-equal? (src->vector (list 'source 1 0 1 0))
(vector 'source 1 0 1 0)))
(test-ok (check-equal? (src->vector (vector 'source 1 0 1 0))
(vector 'source 1 0 1 0)))
(test-ok (check-equal? (src->vector) (vector #f #f #f #f #f)))
(test-ok (check-equal? (src->vector (make-srcloc 'one 1 0 1 0)
(make-srcloc 'two 1 0 1 0))
(vector #f #f #f #f #f)))
(test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0)
(make-srcloc 'source 2 1 2 1))
(vector 'source 1 0 1 2))))
(test-suite "src->syntax"
(test-ok (check-pred syntax? (src->syntax #f)))
(test-ok (check-pred syntax?
(src->syntax (make-srcloc 'source 1 0 1 0))))
(test-ok (check-pred syntax? (src->syntax (datum->syntax #f 'here #f))))
(test-ok (check-pred syntax? (src->syntax (list 'source 1 0 1 0))))
(test-ok (check-pred syntax? (src->syntax (vector 'source 1 0 1 0))))
(test-ok (check-pred syntax? (src->syntax)))
(test-ok (check-pred syntax? (src->syntax (make-srcloc 'one 1 0 1 0)
(make-srcloc 'two 1 0 1 0))))
(test-ok (check-pred syntax?
(src->syntax (make-srcloc 'source 1 0 1 0)
(make-srcloc 'source 2 1 2 1)))))
(test-suite "src-known?"
(test-ok (check-false (src-known? (list #f #f #f #f #f))))
(test-ok (check-true (src-known? (vector 'source #f #f #f #f))))
(test-ok (check-true (src-known? (datum->syntax #f 'x
(list 'a 1 2 3 4)))))))
(test-suite "Syntax Lists"
(test-suite "syntax-list"
(test
(check-equal?
(with-syntax ([([x ...] ...) #'([1 2] [3] [4 5 6])])
(map syntax->datum (syntax-list x ... ...)))
(list 1 2 3 4 5 6))))
(test-suite "syntax-map"
(test-case "identifiers to symbols"
(check-equal? (syntax-map syntax-e #'(a b c)) '(a b c)))))
(test-suite "Syntax Conversions"
(test-suite "to-syntax"
(test-case "symbol + context = identifier"
(check bound-identifier=?
(to-syntax #:stx #'context 'id)
#'id)))
(test-suite "to-datum"
(test-case "syntax"
(check-equal? (to-datum #'((a b) () (c)))
'((a b) () (c))))
(test-case "non-syntax"
(check-equal? (to-datum '((a b) () (c)))
'((a b) () (c))))
(test-case "nested syntax"
(let* ([stx-ab #'(a b)]
[stx-null #'()]
[stx-c #'(c)])
(check-equal? (to-datum (list stx-ab stx-null stx-c))
(list stx-ab stx-null stx-c))))))
(test-suite "Syntax Source Locations"
(test-suite "syntax-source-file-name"
(test-case "here"
(check-equal? (syntax-source-file-name here)
(this-expression-file-name)))
(test-case "fail"
(check-equal? (syntax-source-file-name (datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-directory"
(test-case "here"
(check-equal? (syntax-source-directory here)
(this-expression-source-directory)))
(test-case "fail"
(check-equal? (syntax-source-directory (datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package"
(test-case "fail"
(check-equal? (syntax-source-planet-package (datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-owner"
(test-case "fail"
(check-equal? (syntax-source-planet-package-owner
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-name"
(test-case "fail"
(check-equal? (syntax-source-planet-package-name
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-major"
(test-case "fail"
(check-equal? (syntax-source-planet-package-major
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-minor"
(test-case "fail"
(check-equal? (syntax-source-planet-package-minor
(datum->syntax #f 'fail))
#f)))
(test-suite "syntax-source-planet-package-symbol"
(test-case "fail"
(check-equal? (syntax-source-planet-package-minor
(datum->syntax #f 'fail))
#f)))
(test-suite "make-planet-path"))
(test-suite "Transformers"
(test-suite "redirect-transformer"
(test (check-equal?
(syntax->datum ((redirect-transformer #'x) #'y))
'x))
(test (check-equal?
(syntax->datum ((redirect-transformer #'x) #'(y z)))
'(x z))))
(test-suite "full-kernel-form-identifier-list"
(test (check-pred list? (full-kernel-form-identifier-list)))
(test (for ([id (in-list (full-kernel-form-identifier-list))])
(check-pred identifier? id))))
(test-suite "head-expand")
(test-suite "trampoline-transformer")
(test-suite "quote-transformer"))
(test-suite "Pattern Bindings"
(test-suite "with-syntax*"
(test-case "identifier"
(check bound-identifier=?
(with-syntax* ([a #'id] [b #'a]) #'b)
#'id))))))

35
collects/unstable/contract.rkt
View File

@ -77,6 +77,36 @@
(define truth/c
(flat-named-contract '|truth value| (lambda (x) #t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Contracts
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (syntax-datum/c datum)
(let* ([datum/c (coerce-contract datum datum)])
(flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate datum/c)
(syntax->datum v)))))))
(define (syntax-listof/c elem)
(let* ([elem/c (coerce-contract elem elem)])
(flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (listof elem/c))
(syntax->list v)))))))
(define (syntax-list/c . elems)
(let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
(flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (apply list/c elem/cs))
(syntax->list v)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Function Contracts
@ -328,5 +358,10 @@
[predicate-like/c contract?]
[comparison-like/c contract?]
[syntax-datum/c (-> flat-contract? flat-contract?)]
[syntax-listof/c (-> flat-contract? flat-contract?)]
[syntax-list/c
(->* [] [] #:rest (listof flat-contract?) flat-contract?)]
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
[dict/c (-> contract? contract? contract?)])

53
collects/unstable/planet-syntax.rkt Normal file
View File

@ -0,0 +1,53 @@
#lang racket/base
(provide make-planet-path
syntax-source-planet-package
syntax-source-planet-package-owner
syntax-source-planet-package-name
syntax-source-planet-package-major
syntax-source-planet-package-minor
syntax-source-planet-package-symbol)
(require racket/match planet/util unstable/syntax)
(define (syntax-source-planet-package stx)
(let* ([dir (syntax-source-directory stx)])
(and dir (path->package-version dir))))
(define (syntax-source-planet-package-owner stx)
(match (syntax-source-planet-package stx)
[(list owner name major minor) owner]
[_ #f]))
(define (syntax-source-planet-package-name stx)
(match (syntax-source-planet-package stx)
[(list owner name major minor) name]
[_ #f]))
(define (syntax-source-planet-package-major stx)
(match (syntax-source-planet-package stx)
[(list owner name major minor) major]
[_ #f]))
(define (syntax-source-planet-package-minor stx)
(match (syntax-source-planet-package stx)
[(list owner name major minor) minor]
[_ #f]))
(define (syntax-source-planet-package-symbol stx [suffix #f])
(match (syntax-source-planet-package stx)
[(list owner name major minor)
(string->symbol
(format "~a/~a:~a:~a~a"
owner
(regexp-replace "\\.plt$" name "")
major
minor
(if suffix (format-symbol "/~a" suffix) "")))]
[#f #f]))
(define (make-planet-path stx id/f)
(datum->syntax
stx
(list #'planet (syntax-source-planet-package-symbol stx id/f))
(or id/f stx)))

16
collects/unstable/private/expand.ss Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
(require (for-syntax racket/base))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Trampoline Expansion
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide #%trampoline)
(define-syntax (#%trampoline stx)
(syntax-case stx ()
[(_ thunk)
(procedure? (syntax-e #'thunk))
(#%app (syntax-e #'thunk))]))

23
collects/unstable/scribblings/contract.scrbl
View File

@ -80,6 +80,29 @@ that accept arbitrary truth values that may not be booleans.
}
@section{Syntax Object Contracts}
@defproc[(syntax-datum/c [datum/c any/c]) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->datum stx)]
satisfies @scheme[datum/c].
}
@defproc[(syntax-listof/c [elem/c any/c]) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
satisfies @scheme[(listof elem/c)].
}
@defproc[(syntax-list/c [elem/c any/c] ...) flat-contract?]{
Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)]
satisfies @scheme[(list/c elem/c ...)].
}
@section{Higher-Order Contracts}
@deftogether[(

68
collects/unstable/scribblings/planet-syntax.scrbl Normal file
View File

@ -0,0 +1,68 @@
#lang scribble/manual
@(require scribble/eval "utils.rkt" (for-label racket unstable/planet-syntax))
@title{Planet Package Macros}
@defmodule[unstable/planet-syntax]
@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
@deftogether[(
@defproc[(syntax-source-planet-package [stx syntax?])
(or/c (list/c string?
string?
exact-nonnegative-integer?
exact-nonnegative-integer?)
#f)]
@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-major [stx syntax?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(syntax-source-planet-package-minor [stx syntax?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(syntax-source-planet-package-symbol
[stx syntax?]
[text (or/c text? #f) #f])
(or/c symbol? #f)]
)]{
These functions extract the planet package with which @scheme[stx] is
associated, if any, based on its source location information and the currently
installed set of planet packages. They produce, respectively, the planet
package s-expression, its owner, name, major version number, minor version
number, or a symbol corresponding to a @scheme[planet] module path. They each
produce @scheme[#f] if @scheme[stx] is not associated with a planet package.
@defexamples[
#:eval (eval/require 'unstable/planet-syntax)
(define loc
(list (build-path (current-directory) "file.ss")
#f #f #f #f))
(define stx (datum->syntax #f 'stx loc))
(syntax-source-planet-package stx)
(syntax-source-planet-package-owner stx)
(syntax-source-planet-package-name stx)
(syntax-source-planet-package-major stx)
(syntax-source-planet-package-minor stx)
(syntax-source-planet-package-symbol stx)
(syntax-source-planet-package-symbol stx "there")
]
}
@defproc[(make-planet-path [stx syntax?] [id (or/c identifier? #f)]) syntax?]{
Constructs a syntax object representing a require spec for the planet package
from which @scheme[stx] arises, with suffix @scheme[id] (if any).
@defexamples[
#:eval (eval/require 'unstable/planet-syntax)
(define loc
(list (build-path (current-directory) "file.ss")
#f #f #f #f))
(define stx (datum->syntax #f 'stx loc))
(make-planet-path stx #f)
(make-planet-path stx #'there)
]
}

166
collects/unstable/scribblings/syntax.scrbl
View File

@ -5,6 +5,7 @@
"utils.rkt"
(for-label racket/base
racket/contract
syntax/kerncase
unstable/syntax))
@(define the-eval (make-base-eval))
@ -313,3 +314,168 @@ Performs @racket[(map f (syntax->list stxl) ...)].
@examples[#:eval the-eval
(syntax-map syntax-e #'(a b c))]
}
@addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
@defform[(syntax-list template ...)]{
This form constructs a list of syntax objects based on the given templates. It
is equivalent to @scheme[(syntax->list (syntax (template ...)))].
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
(with-syntax ([(x ...) (syntax (1 2 3))]) (syntax-list x ...))
]
}
@defproc[(to-syntax [datum any/c]
[#:stx stx (or/c false/c syntax?) #f]
[#:src src src/c stx]
[#:ctxt ctxt (or/c false/c syntax?) stx]
[#:prop prop (or/c false/c syntax?) stx]
[#:cert cert (or/c false/c syntax?) stx])
syntax?]{
A wrapper for @scheme[datum->syntax] with keyword arguments.
The "master" keyword @scheme[#:stx] sets all attributes from a single syntax
object, defaulting to @scheme[#f] for unadorned syntax objects.
The individual keywords @scheme[#:src], @scheme[#:ctxt], @scheme[#:prop], and
@scheme[#:cert] override @scheme[#:stx] for individual syntax object
attributes. They control source src information, lexical context
information, syntax object properties, and syntax certificates, respectively.
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
(define blank-stx (to-syntax 'car))
blank-stx
(syntax-e blank-stx)
(free-identifier=? blank-stx #'car)
(define full-stx (to-syntax 'car #:stx #'here))
full-stx
(syntax-e full-stx)
(free-identifier=? full-stx #'car)
(define partial-stx (to-syntax 'car #:ctxt #'here))
partial-stx
(syntax-e partial-stx)
(free-identifier=? partial-stx #'car)
]
}
@section{Syntax Object Source Locations}
@deftogether[(
@defproc[(syntax-source-directory [stx syntax?]) (or/c path? #f)]
@defproc[(syntax-source-file-name [stx syntax?]) (or/c path? #f)]
)]{
These produce the directory and file name, respectively, of the path with which
@scheme[stx] is associated, or @scheme[#f] if @scheme[stx] is not associated
with a path.
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
(define loc
(list (build-path "/tmp" "dir" "somewhere.ss")
#f #f #f #f))
(define stx1 (datum->syntax #f 'somewhere loc))
(syntax-source-directory stx1)
(syntax-source-file-name stx1)
(define stx2 (datum->syntax #f 'nowhere #f))
(syntax-source-directory stx2)
(syntax-source-directory stx2)
]
}
@section{Macro Transformers}
@defproc[(redirect-transformer [id identifier?]) (-> syntax? syntax?)]{
Constructs a function that behaves like a rename transformer; it does not
cooperate with @scheme[syntax-local-value] like a rename transformer does, but
unlike a rename transformer it may be used as a function to transform a syntax
object referring to one identifier into a syntax object referring to another.
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
((redirect-transformer #'x) #'a)
((redirect-transformer #'y) #'(a b c))
]
}
@defproc[(head-expand [stx syntax?] [stop-list (listof identifier?)]) syntax?]{
This function performs head expansion on @scheme[stx]. In other words, it uses
@scheme[local-expand] to expand @scheme[stx] until its head identifier is a core
form (a member of @scheme[(kernel-form-identifier-list)]) or a member of
@scheme[stop-list], or until it can not be expanded further (e.g. due to error).
It is equivalent to @scheme[(local-expand stx (syntax-local-context) (append
stop-ids (kernel-form-identifier-list) #f))].
}
@defproc[(trampoline-transformer
[f (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)])
(-> syntax? syntax?)]{
Produces a transformer that can emit multiple results during macro expansion, to
be spliced together via @scheme[begin]. This can be useful for compound
expansion that relies on transformer definitions, as well as on expansion state
that is difficult to marshall.
Specifically, @scheme[f] is invoked with three arguments. The first is the
function used to emit intermediate results (other than the last one). The
second applies the @tech[#:doc '(lib
"scribblings/reference/reference.scrbl")]{syntax mark} used for the entire
expansion; @scheme[syntax-local-introduce] will not be reliable during this
process. The third is the syntax object to expand.
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
(define-syntax magic-begin
(trampoline-transformer
(lambda (emit intro stx)
(syntax-case stx ()
[(_ term ...)
(let loop ([terms (syntax->list #'(term ...))])
(cond
[(null? terms) #'(begin)]
[(null? (cdr terms)) (car terms)]
[else
(printf "Presto: ~s!\n"
(syntax->datum (car terms)))
(emit (car terms))
(loop (cdr terms))]))]))))
(magic-begin
(define x 1)
(define y 2)
(+ x y))
]
}
@defproc[(quote-transformer [x any/c]) syntax?]{
Produces a syntax object representing an expression that reconstructs @scheme[x]
when executed, including faithfully reconstructing any syntax objects contained
in @scheme[x]. Note that @scheme[quote] normally converts syntax objects to
non-syntax data, and @scheme[quote-syntax] does the opposite.
@defexamples[
#:eval (eval/require '(for-syntax racket/base unstable/syntax) 'unstable/syntax)
(define-for-syntax x (list 1 #'(2 3) 4))
(define-syntax (the-many-faces-of-x stx)
(with-syntax ([x x] [qx (quote-transformer x)])
#'(list (quote x)
(quote-syntax x)
qx)))
(the-many-faces-of-x)
]
}

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -91,6 +91,7 @@ Keep documentation and tests up to date.
@include-section["string.scrbl"]
@include-section["struct.scrbl"]
@include-section["syntax.scrbl"]
@include-section["planet-syntax.scrbl"]
@include-section["text.scrbl"]
@include-section["values.scrbl"]
@include-section["web.scrbl"]

160
collects/unstable/syntax.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base
;; owner: ryanc
;; owner: ryanc (and cce, where noted)
(require syntax/kerncase
syntax/stx
unstable/struct
unstable/srcloc
(for-syntax racket/base
racket/private/sc)
(for-template racket/base))
(for-template racket/base unstable/private/expand))
(provide unwrap-syntax
@ -32,7 +33,24 @@
syntax-local-eval
with-syntax*
syntax-map)
syntax-map
;; by cce:
to-syntax
to-datum
syntax-source-file-name
syntax-source-directory
trampoline-transformer
quote-transformer
redirect-transformer
head-expand
syntax-list
)
;; Unwrapping syntax
@ -246,3 +264,139 @@
(define (syntax-map f . stxls)
(apply map f (map syntax->list stxls)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; By Carl Eastlund, below
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Pattern Bindings
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax-rule (syntax-list template ...)
(syntax->list (syntax (template ...))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Conversions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (to-syntax datum
#:stx [stx #f]
#:src [src stx]
#:ctxt [ctxt stx]
#:prop [prop stx]
#:cert [cert stx])
(datum->syntax ctxt
datum
(if (srcloc? src) (build-source-location-list src) src)
prop
cert))
;; Slightly different from unwrap-syntax,
;; in that it doesn't traverse anything that isn't immediately syntax.
;; At some point we should pick one of the other or a combination,
;; both is probably overkill.
(define (to-datum v)
(if (syntax? v) (syntax->datum v) v))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Locations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (syntax-source-directory stx)
(let* ([source (syntax-source stx)])
(and (path-string? source)
(let-values ([(base file dir?) (split-path source)])
(and (path? base)
(path->complete-path base
(or (current-load-relative-directory)
(current-directory))))))))
(define (syntax-source-file-name stx)
(let* ([f (syntax-source stx)])
(and (path-string? f)
(let-values ([(base file dir?) (split-path f)]) file))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Transformer Patterns
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((redirect-transformer id) stx)
(cond
[(identifier? stx) id]
[(and (stx-pair? stx) (identifier? (stx-car stx)))
(to-syntax (cons id (stx-cdr stx)) #:stx stx)]
[else
(wrong-syntax
stx
"expected an identifier (alone or in application position); cannot redirect to ~a"
(syntax-e id))]))
(define (head-expand stx [stop-ids null])
(local-expand stx
(syntax-local-context)
(append stop-ids (kernel-form-identifier-list))
#f))
(define (quote-transformer datum)
#`(quasiquote
#,(let loop ([datum datum])
(cond
[(syntax? datum) #`(unquote (quote-syntax #,datum))]
[(pair? datum) #`#,(cons (loop (car datum)) (loop (cdr datum)))]
[(vector? datum)
#`#,(apply vector-immutable (map loop (vector->list datum)))]
[(box? datum) #`#,(box (loop (unbox datum)))]
[(hash? datum)
#`#,((cond [(hash-eqv? datum) make-immutable-hasheqv]
[(hash-eq? datum) make-immutable-hasheq]
[else make-immutable-hash])
(hash-map datum (lambda (k v) (cons k (loop v)))))]
[(prefab-struct-key datum) =>
(lambda (key)
#`#,(apply make-prefab-struct
key
(for/list ([i (in-vector (struct->vector datum) 1)])
(loop i))))]
[else #`#,datum]))))
(define trampoline-prompt-tag
(make-continuation-prompt-tag 'trampoline))
(define ((trampoline-transformer transform) stx)
(define intro (make-syntax-introducer))
(define (body)
(syntax-local-introduce
(intro
(transform (trampoline-evaluator intro)
intro
(intro (syntax-local-introduce stx))))))
(call-with-continuation-prompt body trampoline-prompt-tag))
(define ((trampoline-evaluator intro) stx)
(define ((wrap continue))
(call-with-continuation-prompt continue trampoline-prompt-tag))
(define ((expander continue))
#`(begin #,(syntax-local-introduce (intro stx))
(#%trampoline #,(wrap continue))))
(define (body continue)
(abort-current-continuation trampoline-prompt-tag (expander continue)))
(call-with-composable-continuation body trampoline-prompt-tag)
(void))