scribble/manual: add #:id' option to defproc'
Also, convert the implementation of `defproc', `defform', etc. to use `syntax-parse'. original commit: 6028a60f6588f11dfe1b466df24513256e1b84c4
This commit is contained in:
Matthew Flatt
parent
378f9c3bae
commit
937d4f0e59
|
|
@ -10,7 +10,9 @@
|
|||
"manual-scheme.rkt"
|
||||
"manual-bind.rkt"
|
||||
scheme/list
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax scheme/base
|
||||
syntax/parse
|
||||
racket/syntax)
|
||||
(for-label scheme/base))
|
||||
|
||||
(provide defform defform* defform/subs defform*/subs defform/none
|
||||
|
|
@ -24,226 +26,123 @@
|
|||
[racketgrammar* schemegrammar*])
|
||||
var svar)
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class kind-kw
|
||||
#:description "#:kind keyword"
|
||||
(pattern (~optional (~seq #:kind kind)
|
||||
#:defaults ([kind #'#f]))))
|
||||
|
||||
(define-splicing-syntax-class id-kw
|
||||
#:description "#:id keyword"
|
||||
(pattern (~seq #:id [defined-id:id defined-id-expr]))
|
||||
(pattern (~seq #:id defined-id:id)
|
||||
#:with defined-id-expr #'(quote-syntax defined-id))
|
||||
(pattern (~seq #:id [#f #f])
|
||||
#:with defined-id #'#f
|
||||
#:with defined-id-expr #'#f)
|
||||
(pattern (~seq)
|
||||
#:with defined-id #'#f
|
||||
#:with defined-id-expr #'#f))
|
||||
|
||||
(define-splicing-syntax-class literals-kw
|
||||
#:description "#:literals keyword"
|
||||
(pattern (~optional (~seq #:literals (lit:id ...))
|
||||
#:defaults ([(lit 1) '()]))))
|
||||
|
||||
(define-splicing-syntax-class contracts-kw
|
||||
#:description "#:contracts keyword"
|
||||
(pattern (~optional (~seq #:contracts ([contract-nonterm:id contract-expr] ...))
|
||||
#:defaults ([(contract-nonterm 1) '()]
|
||||
[(contract-expr 1) '()]))))
|
||||
|
||||
(define-syntax-class grammar
|
||||
(pattern ([non-term-id:id non-term-form ...] ...)))
|
||||
)
|
||||
|
||||
(define-syntax (defform*/subs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ([contract-nonterm contract-expr] ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw d:id-kw l:literals-kw [spec spec1 ...]
|
||||
g:grammar
|
||||
c:contracts-kw
|
||||
desc ...)
|
||||
(with-syntax ([(defined-id defined-id-expr)
|
||||
(if (identifier? #'defined-id)
|
||||
(syntax [defined-id (quote-syntax defined-id)])
|
||||
#'defined-id)])
|
||||
(with-syntax ([new-spec
|
||||
(let loop ([spec #'spec])
|
||||
(if (and (identifier? spec)
|
||||
(free-identifier=? spec #'defined-id))
|
||||
(datum->syntax #'here '(unsyntax x) spec spec)
|
||||
(syntax-case spec ()
|
||||
[(a . b)
|
||||
(datum->syntax spec
|
||||
(cons (loop #'a) (loop #'b))
|
||||
spec
|
||||
spec)]
|
||||
[_ spec])))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for a literal"
|
||||
stx
|
||||
id)))
|
||||
(syntax->list #'(lit ...)))
|
||||
(with-syntax* ([defined-id (if (syntax-e #'d.defined-id)
|
||||
#'d.defined-id
|
||||
(syntax-case #'spec ()
|
||||
[(spec-id . _) #'spec-id]))]
|
||||
[defined-id-expr (if (syntax-e #'d.defined-id-expr)
|
||||
#'d.defined-id-expr
|
||||
#'(quote-syntax defined-id))]
|
||||
[new-spec
|
||||
(let loop ([spec #'spec])
|
||||
(if (and (identifier? spec)
|
||||
(free-identifier=? spec #'defined-id))
|
||||
(datum->syntax #'here '(unsyntax x) spec spec)
|
||||
(syntax-case spec ()
|
||||
[(a . b)
|
||||
(datum->syntax spec
|
||||
(cons (loop #'a) (loop #'b))
|
||||
spec
|
||||
spec)]
|
||||
[_ spec])))])
|
||||
#'(with-togetherable-racket-variables
|
||||
(lit ...)
|
||||
(l.lit ...)
|
||||
([form [defined-id spec]] [form [defined-id spec1]] ...
|
||||
[non-term (non-term-id non-term-form ...)] ...)
|
||||
(*defforms kind defined-id-expr
|
||||
[non-term (g.non-term-id g.non-term-form ...)] ...)
|
||||
(*defforms k.kind defined-id-expr
|
||||
'(spec spec1 ...)
|
||||
(list (lambda (x) (racketblock0/form new-spec))
|
||||
(lambda (ignored) (racketblock0/form spec1)) ...)
|
||||
'((non-term-id non-term-form ...) ...)
|
||||
(list (list (lambda () (racket non-term-id))
|
||||
(lambda () (racketblock0/form non-term-form))
|
||||
'((g.non-term-id g.non-term-form ...) ...)
|
||||
(list (list (lambda () (racket g.non-term-id))
|
||||
(lambda () (racketblock0/form g.non-term-form))
|
||||
...)
|
||||
...)
|
||||
(list (list (lambda () (racket contract-nonterm))
|
||||
(lambda () (racketblock0 contract-expr)))
|
||||
(list (list (lambda () (racket c.contract-nonterm))
|
||||
(lambda () (racketblock0 c.contract-expr)))
|
||||
...)
|
||||
(lambda () (list desc ...))))))]
|
||||
[(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ([contract-nonterm contract-expr] ...)
|
||||
desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ([contract-nonterm contract-expr] ...)
|
||||
desc ...))]
|
||||
[(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ()
|
||||
desc ...))]
|
||||
[(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ()
|
||||
desc ...))]
|
||||
[(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f #:id id #:literals () [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ()
|
||||
desc ...))]
|
||||
[(fm #:kind kind #:literals lits [(spec-id . spec-rest) spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(with-syntax ([(_ _ _ _ _ [spec . _] . _) stx])
|
||||
(syntax/loc stx
|
||||
(fm #:kind kind #:id spec-id #:literals lits [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)))]
|
||||
[(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(with-syntax ([(_ _ _ [spec . _] . _) stx])
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f #:id spec-id #:literals lits [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)))]
|
||||
[(fm #:kind kind [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind kind #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
desc ...))]
|
||||
[(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
desc ...))]))
|
||||
(lambda () (list desc ...)))))]))
|
||||
|
||||
(define-syntax (defform* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind #:id id #:literals lits [spec ...] desc ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw d:id-kw l:literals-kw [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id #:literals lits [spec ...] () desc ...))]
|
||||
[(_ #:id id #:literals lits [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id #:literals lits [spec ...] () desc ...))]
|
||||
[(_ #:kind kind #:literals lits [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:literals lits [spec ...] () desc ...))]
|
||||
[(_ #:literals lits [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:literals lits [spec ...] () desc ...))]
|
||||
[(_ #:kind kind #:id id [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id [spec ...] () desc ...))]
|
||||
[(_ #:id id [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id [spec ...] () desc ...))]
|
||||
[(_ #:kind kind [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind [spec ...] () desc ...))]
|
||||
[(_ [spec ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs [spec ...] () desc ...))]))
|
||||
(defform*/subs #:kind k.kind
|
||||
#:id [d.defined-id d.defined-id-expr]
|
||||
#:literals (l.lit ...)
|
||||
[spec ...] () desc ...))]))
|
||||
|
||||
(define-syntax (defform stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind #:id id #:literals (lit ...) spec desc ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw d:id-kw l:literals-kw spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id #:literals (lit ...) [spec] () desc ...))]
|
||||
[(_ #:id id #:literals (lit ...) spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))]
|
||||
[(_ #:kind kind #:id id spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id #:literals () [spec] () desc ...))]
|
||||
[(_ #:id id spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id #:literals () [spec] () desc ...))]
|
||||
[(_ #:literals (lit ...) spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:literals (lit ...) [spec] () desc ...))]
|
||||
[(_ #:kind kind #:literals (lit ...) spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:literals (lit ...) [spec] () desc ...))]
|
||||
[(_ #:kind kind spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind [spec] () desc ...))]
|
||||
[(_ spec desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs [spec] () desc ...))]))
|
||||
(defform*/subs #:kind k.kind
|
||||
#:id [d.defined-id d.defined-id-expr]
|
||||
#:literals (l.lit ...)
|
||||
[spec] () desc ...))]))
|
||||
|
||||
(define-syntax (defform/subs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind #:id id #:literals lits spec subs desc ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw d:id-kw l:literals-kw spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id #:literals lits [spec] subs desc ...))]
|
||||
[(_ #:id id #:literals lits spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id #:literals lits [spec] subs desc ...))]
|
||||
[(_ #:kind kind #:id id spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:id id #:literals () [spec] subs desc ...))]
|
||||
[(_ #:id id spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:id id #:literals () [spec] subs desc ...))]
|
||||
[(_ #:kind kind #:literals lits spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind #:literals lits [spec] subs desc ...))]
|
||||
[(_ #:literals lits spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:literals lits [spec] subs desc ...))]
|
||||
[(_ #:kind kind spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs #:kind kind [spec] subs desc ...))]
|
||||
[(_ spec subs desc ...)
|
||||
(syntax/loc stx
|
||||
(defform*/subs [spec] subs desc ...))]))
|
||||
(defform*/subs #:kind k.kind
|
||||
#:id [d.defined-id d.defined-id-expr]
|
||||
#:literals (l.lit ...)
|
||||
[spec] subs desc ...))]))
|
||||
|
||||
(define-syntax (defform/none stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
|
||||
(begin
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for a literal"
|
||||
stx
|
||||
id)))
|
||||
(syntax->list #'(lit ...)))
|
||||
#'(with-togetherable-racket-variables
|
||||
(lit ...)
|
||||
([form/none spec])
|
||||
(*defforms kind #f
|
||||
'(spec) (list (lambda (ignored) (racketblock0/form spec)))
|
||||
null null
|
||||
(list (list (lambda () (racket contract-id))
|
||||
(lambda () (racketblock0 contract-expr)))
|
||||
...)
|
||||
(lambda () (list desc ...)))))]
|
||||
[(fm #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw l:literals-kw spec c:contracts-kw desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...))]
|
||||
[(fm #:kind kind #:literals (lit ...) spec desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind kind #:literals (lit ...) spec #:contracts () desc ...))]
|
||||
[(fm #:literals (lit ...) spec desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:literals (lit ...) spec #:contracts () desc ...))]
|
||||
[(fm #:kind kind spec desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind kind #:literals () spec desc ...))]
|
||||
[(fm spec desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:literals () spec desc ...))]))
|
||||
(with-togetherable-racket-variables
|
||||
(l.lit ...)
|
||||
([form/none spec])
|
||||
(*defforms k.kind #f
|
||||
'(spec) (list (lambda (ignored) (racketblock0/form spec)))
|
||||
null null
|
||||
(list (list (lambda () (racket c.contract-id))
|
||||
(lambda () (racketblock0 c.contract-expr)))
|
||||
...)
|
||||
(lambda () (list desc ...)))))]))
|
||||
|
||||
(define-syntax (defidform/inline stx)
|
||||
(syntax-case stx (unsyntax)
|
||||
|
|
@ -254,21 +153,18 @@
|
|||
#'(defform-site id-expr)]))
|
||||
|
||||
(define-syntax (defidform stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:kind kind spec-id desc ...)
|
||||
(syntax-parse stx
|
||||
[(_ k:kind-kw spec-id desc ...)
|
||||
#'(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defforms kind (quote-syntax/loc spec-id)
|
||||
(*defforms k.kind (quote-syntax/loc spec-id)
|
||||
'(spec-id)
|
||||
(list (lambda (x) (make-omitable-paragraph (list x))))
|
||||
null
|
||||
null
|
||||
null
|
||||
(lambda () (list desc ...))))]
|
||||
[(fm spec-id desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f spec-id desc ...))]))
|
||||
(lambda () (list desc ...))))]))
|
||||
|
||||
(define (into-blockquote s)
|
||||
(make-blockquote "leftindent"
|
||||
|
|
@ -284,46 +180,40 @@
|
|||
(syntax-case stx ()
|
||||
[(_ . rest) #'(into-blockquote (defform* . rest))]))
|
||||
|
||||
(define-syntax spec?form/subs
|
||||
(syntax-rules ()
|
||||
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
#:contracts ([contract-nonterm contract-expr] ...)
|
||||
(define-syntax (spec?form/subs stx)
|
||||
(syntax-parse stx
|
||||
[(_ has-kw? l:literals-kw spec g:grammar
|
||||
c:contracts-kw
|
||||
desc ...)
|
||||
(with-racket-variables
|
||||
(lit ...)
|
||||
([form/maybe (has-kw? spec)]
|
||||
[non-term (non-term-id non-term-form ...)] ...)
|
||||
(*specsubform 'spec '(lit ...) (lambda () (racketblock0/form spec))
|
||||
'((non-term-id non-term-form ...) ...)
|
||||
(list (list (lambda () (racket non-term-id))
|
||||
(lambda () (racketblock0/form non-term-form))
|
||||
...)
|
||||
...)
|
||||
(list (list (lambda () (racket contract-nonterm))
|
||||
(lambda () (racketblock0 contract-expr)))
|
||||
...)
|
||||
(lambda () (list desc ...))))]
|
||||
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(spec?form/subs has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
#:contracts ()
|
||||
desc ...)]))
|
||||
(syntax/loc stx
|
||||
(with-racket-variables
|
||||
(l.lit ...)
|
||||
([form/maybe (has-kw? spec)]
|
||||
[non-term (g.non-term-id g.non-term-form ...)] ...)
|
||||
(*specsubform 'spec '(l.lit ...) (lambda () (racketblock0/form spec))
|
||||
'((g.non-term-id g.non-term-form ...) ...)
|
||||
(list (list (lambda () (racket g.non-term-id))
|
||||
(lambda () (racketblock0/form g.non-term-form))
|
||||
...)
|
||||
...)
|
||||
(list (list (lambda () (racket c.contract-nonterm))
|
||||
(lambda () (racketblock0 c.contract-expr)))
|
||||
...)
|
||||
(lambda () (list desc ...)))))]))
|
||||
|
||||
(define-syntax specsubform
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec desc ...)
|
||||
(spec?form/subs #f #:literals (lit ...) spec () desc ...)]
|
||||
[(_ spec desc ...)
|
||||
(specsubform #:literals () spec desc ...)]))
|
||||
(define-syntax (specsubform stx)
|
||||
(syntax-parse stx
|
||||
[(_ l:literals-kw spec desc ...)
|
||||
(syntax/loc stx
|
||||
(spec?form/subs #f #:literals (l.lit ...) spec () desc ...))]))
|
||||
|
||||
(define-syntax specsubform/subs
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)]
|
||||
[(_ spec subs desc ...)
|
||||
(specsubform/subs #:literals () spec subs desc ...)]))
|
||||
(define-syntax (specsubform/subs stx)
|
||||
(syntax-parse stx
|
||||
[(_ l:literals-kw spec g:grammar desc ...)
|
||||
(syntax/loc stx
|
||||
(spec?form/subs #f #:literals (l.lit ...) spec
|
||||
([g.non-term-id g.non-term-form ...] ...)
|
||||
desc ...))]))
|
||||
|
||||
(define-syntax-rule (specspecsubform spec desc ...)
|
||||
(make-blockquote "leftindent" (list (specsubform spec desc ...))))
|
||||
|
|
@ -338,15 +228,13 @@
|
|||
[(_ spec desc ...)
|
||||
(specform #:literals () spec desc ...)]))
|
||||
|
||||
(define-syntax specform/subs
|
||||
(syntax-rules ()
|
||||
[(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
(define-syntax (specform/subs stx)
|
||||
(syntax-parse stx
|
||||
[(_ l:literals-kw spec g:grammar
|
||||
desc ...)
|
||||
(spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)]
|
||||
[(_ spec ([non-term-id non-term-form ...] ...) desc ...)
|
||||
(specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
|
||||
desc ...)]))
|
||||
(syntax/loc stx
|
||||
(spec?form/subs #t #:literals (l.lit ...) spec ([g.non-term-id g.non-term-form ...] ...)
|
||||
desc ...))]))
|
||||
|
||||
(define-syntax-rule (specsubform/inline spec desc ...)
|
||||
(with-racket-variables
|
||||
|
|
|
|||
|
|
@ -17,7 +17,8 @@
|
|||
"on-demand.rkt"
|
||||
scheme/string
|
||||
scheme/list
|
||||
(for-syntax racket/base)
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
(for-label racket/base
|
||||
racket/contract
|
||||
racket/class))
|
||||
|
|
@ -78,11 +79,14 @@
|
|||
|
||||
(define-syntax (extract-proc-id stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
[(_ k e id)
|
||||
(identifier? #'id)
|
||||
#`(quote-syntax/loc id)]
|
||||
[(_ (proto arg ...))
|
||||
#'(extract-proc-id proto)]
|
||||
(if (and (syntax-e #'k)
|
||||
(free-identifier=? #'k #'id))
|
||||
#'e
|
||||
#`(quote-syntax/loc id))]
|
||||
[(_ k e (proto arg ...))
|
||||
#'(extract-proc-id k e proto)]
|
||||
[(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)]))
|
||||
|
||||
(define-syntax (arg-contracts stx)
|
||||
|
|
@ -113,39 +117,62 @@
|
|||
"expected a result contract, found a string" #'c)
|
||||
#'(racketblock0 c))]))
|
||||
|
||||
(define-syntax defproc
|
||||
(syntax-rules ()
|
||||
[(_ #:kind kind (id arg ...) result desc ...)
|
||||
(defproc* #:kind kind [[(id arg ...) result]] desc ...)]
|
||||
[(_ (id arg ...) result desc ...)
|
||||
(defproc* [[(id arg ...) result]] desc ...)]))
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class kind-kw
|
||||
#:description "#:kind keyword"
|
||||
(pattern (~optional (~seq #:kind kind)
|
||||
#:defaults ([kind #'#f]))))
|
||||
|
||||
(define-syntax defproc*
|
||||
(syntax-rules ()
|
||||
[(_ #:kind kind #:mode m #:within cl [[proto result] ...] desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
([proc proto] ...)
|
||||
(*defproc kind
|
||||
'm (quote-syntax/loc cl)
|
||||
(list (extract-proc-id proto) ...)
|
||||
'[proto ...]
|
||||
(list (arg-contracts proto) ...)
|
||||
(list (arg-defaults proto) ...)
|
||||
(list (lambda () (result-contract result)) ...)
|
||||
(lambda () (list desc ...))))]
|
||||
[(_ #:mode m #:within cl [[proto result] ...] desc ...)
|
||||
(defproc* #:kind #f #:mode m #:within cl [[proto result] ...] desc ...)]
|
||||
[(_ #:kind kind [[proto result] ...] desc ...)
|
||||
(defproc* #:kind kind #:mode procedure #:within #f [[proto result] ...] desc ...)]
|
||||
[(_ [[proto result] ...] desc ...)
|
||||
(defproc* #:kind #f #:mode procedure #:within #f [[proto result] ...] desc ...)]))
|
||||
(define-syntax-class id-or-false
|
||||
(pattern i:id)
|
||||
(pattern #f #:with i #'#f))
|
||||
|
||||
(define-splicing-syntax-class id-kw
|
||||
#:description "#:id keyword"
|
||||
(pattern (~optional (~seq #:id [key:id-or-false expr])
|
||||
#:defaults ([key #'#f]
|
||||
[expr #'#f]))))
|
||||
|
||||
(define-splicing-syntax-class mode-kw
|
||||
#:description "#:mode keyword"
|
||||
(pattern (~optional (~seq #:mode m:id)
|
||||
#:defaults ([m #'procedure]))))
|
||||
|
||||
(define-splicing-syntax-class within-kw
|
||||
#:description "#:within keyword"
|
||||
(pattern (~optional (~seq #:within cl:id)
|
||||
#:defaults ([cl #'#f]))))
|
||||
)
|
||||
|
||||
(define-syntax (defproc stx)
|
||||
(syntax-parse stx
|
||||
[(_ kind:kind-kw i:id-kw (id arg ...) result desc ...)
|
||||
(syntax/loc stx
|
||||
(defproc* #:kind kind.kind #:id [i.key i.expr] [[(id arg ...) result]] desc ...))]))
|
||||
|
||||
(define-syntax (defproc* stx)
|
||||
(syntax-parse stx
|
||||
[(_ kind:kind-kw d:id-kw mode:mode-kw within:within-kw [[proto result] ...] desc ...)
|
||||
(syntax/loc stx
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
([proc proto] ...)
|
||||
(let ([alt-id d.expr])
|
||||
(*defproc kind.kind
|
||||
'mode.m (quote-syntax/loc within.cl)
|
||||
(list (extract-proc-id d.key alt-id proto) ...)
|
||||
'd.key
|
||||
'[proto ...]
|
||||
(list (arg-contracts proto) ...)
|
||||
(list (arg-defaults proto) ...)
|
||||
(list (lambda () (result-contract result)) ...)
|
||||
(lambda () (list desc ...))))))]))
|
||||
|
||||
(define-struct arg
|
||||
(special? kw id optional? starts-optional? ends-optional? num-closers))
|
||||
|
||||
(define (*defproc kind mode within-id
|
||||
stx-ids prototypes arg-contractss arg-valss result-contracts
|
||||
stx-ids sym prototypes arg-contractss arg-valss result-contracts
|
||||
content-thunk)
|
||||
(define max-proto-width (current-display-width))
|
||||
(define ((arg->elem show-opt-start?) arg)
|
||||
|
|
@ -240,9 +267,14 @@
|
|||
(arg-id (cadr s)))))
|
||||
(+ 1 (string-length (symbol->string (arg-id (cadr s)))))
|
||||
0)))))))))
|
||||
(define (extract-id p)
|
||||
(define (extract-id p stx-id)
|
||||
(let loop ([p p])
|
||||
(if (symbol? (car p)) (car p) (loop (car p)))))
|
||||
(if (symbol? (car p))
|
||||
(let ([s (car p)])
|
||||
(if (eq? s sym)
|
||||
(syntax-e stx-id)
|
||||
(car p)))
|
||||
(loop (car p)))))
|
||||
(define (do-one stx-id prototype args arg-contracts arg-vals result-contract
|
||||
first? add-background-label?)
|
||||
(let ([names (remq* '(... ...+) (map arg-id args))])
|
||||
|
|
@ -262,7 +294,7 @@
|
|||
(list (racket send) spacer
|
||||
(name-this-object (syntax-e within-id)) spacer
|
||||
(if first?
|
||||
(let* ([mname (extract-id prototype)]
|
||||
(let* ([mname (extract-id prototype stx-id)]
|
||||
[target-maker (id-to-target-maker within-id #f)]
|
||||
[content (list (*method mname within-id))])
|
||||
(if target-maker
|
||||
|
|
@ -285,11 +317,11 @@
|
|||
libs mname ctag)))))
|
||||
tag))))
|
||||
(car content)))
|
||||
(*method (extract-id prototype) within-id))))]
|
||||
(*method (extract-id prototype stx-id) within-id))))]
|
||||
[first?
|
||||
(define the-id (extract-id prototype stx-id))
|
||||
(let ([target-maker (id-to-target-maker stx-id #t)]
|
||||
[content (list (definition-site (extract-id prototype)
|
||||
stx-id #f))])
|
||||
[content (list (definition-site the-id stx-id #f))])
|
||||
(if target-maker
|
||||
(target-maker
|
||||
content
|
||||
|
|
@ -298,21 +330,20 @@
|
|||
#f
|
||||
(list (make-index-element
|
||||
#f content tag
|
||||
(list (datum-intern-literal (symbol->string (extract-id prototype))))
|
||||
(list (datum-intern-literal (symbol->string the-id)))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-procedure-index-desc (extract-id prototype)
|
||||
libs)))))
|
||||
(make-procedure-index-desc the-id libs)))))
|
||||
tag)))
|
||||
(car content)))]
|
||||
[else
|
||||
(define the-id (extract-id prototype stx-id))
|
||||
(annote-exporting-library
|
||||
(let ([sig (current-signature)])
|
||||
(if sig
|
||||
(*sig-elem (sig-id sig) (extract-id prototype))
|
||||
(to-element (make-just-context (extract-id prototype)
|
||||
stx-id)))))]))
|
||||
(*sig-elem (sig-id sig) the-id)
|
||||
(to-element (make-just-context the-id stx-id)))))]))
|
||||
(define p-depth (prototype-depth prototype))
|
||||
(define flat-size (+ (prototype-size args + + #f)
|
||||
p-depth
|
||||
|
|
@ -495,12 +526,13 @@
|
|||
(append-map
|
||||
do-one
|
||||
stx-ids prototypes all-args arg-contractss arg-valss result-contracts
|
||||
(let loop ([ps prototypes] [accum null])
|
||||
(let loop ([ps prototypes] [stx-ids stx-ids] [accum null])
|
||||
(cond [(null? ps) null]
|
||||
[(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
|
||||
(cons #f (loop (cdr ps) accum))]
|
||||
[(ormap (lambda (a) (eq? (extract-id (car ps) (car stx-ids)) a)) accum)
|
||||
(cons #f (loop (cdr ps) (cdr stx-ids) accum))]
|
||||
[else (cons #t (loop (cdr ps)
|
||||
(cons (extract-id (car ps)) accum)))]))
|
||||
(cdr stx-ids)
|
||||
(cons (extract-id (car ps) (car stx-ids)) accum)))]))
|
||||
(for/list ([p (in-list prototypes)]
|
||||
[i (in-naturals)])
|
||||
(= i 0))))))
|
||||
|
|
|
|||
|
|
@ -671,7 +671,7 @@ sub-sections.}
|
|||
@; ------------------------------------------------------------------------
|
||||
@section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values}
|
||||
|
||||
@defform/subs[(defproc maybe-kind prototype
|
||||
@defform/subs[(defproc maybe-kind maybe-id prototype
|
||||
result-contract-expr-datum
|
||||
pre-flow ...)
|
||||
([prototype (id arg-spec ...)
|
||||
|
|
@ -684,6 +684,8 @@ sub-sections.}
|
|||
ellipses+]
|
||||
[maybe-kind code:blank
|
||||
(code:line #:kind kind-string-expr)]
|
||||
[maybe-id code:blank
|
||||
(code:line #:id [src-id dest-id-expr])]
|
||||
[ellipses @#,lit-ellipses]
|
||||
[ellipses+ @#,lit-ellipses+])]{
|
||||
|
||||
|
|
@ -747,10 +749,17 @@ An optional @racket[#:kind] specification chooses the decorative
|
|||
label, which defaults to @racket["procedure"]. A @racket[#f]
|
||||
result for @racket[kind-string-expr] uses the default, otherwise
|
||||
@racket[kind-string-expr] should produce a string. An alternate
|
||||
label should be all lowercase.}
|
||||
label should be all lowercase.
|
||||
|
||||
If @racket[#:id [src-id dest-id-expr]] is supplied, then
|
||||
@racket[src-id] is the identifier as it appears in the
|
||||
@racket[prototype] (to be replaced by a defining instance), and
|
||||
@racket[dest-id-expr] produces the identifier to be documented in
|
||||
place of @racket[src-id]. This split between @racket[src-id] and
|
||||
@racket[dest-id-expr] roles is useful for functional abstraction of
|
||||
@racket[defproc].}
|
||||
|
||||
@defform[(defproc* maybe-kind
|
||||
@defform[(defproc* maybe-kind maybe-id
|
||||
([prototype
|
||||
result-contract-expr-datum] ...)
|
||||
pre-flow ...)]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user