commit 937d4f0e59e75195e64f503f69751de7e98bc182
parent 378f9c3bae0a40b4e93d83ccca996d22da84fdb2
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 25 Jun 2012 23:16:33 -0600
scribble/manual: add `#:id' option to `defproc'
Also, convert the implementation of `defproc', `defform', etc. to
use `syntax-parse'.
original commit: 6028a60f6588f11dfe1b466df24513256e1b84c4
Diffstat:
3 files changed, 234 insertions(+), 305 deletions(-)
diff --git a/collects/scribble/private/manual-form.rkt b/collects/scribble/private/manual-form.rkt
@@ -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/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-parse stx
+ [(_ k:kind-kw d:id-kw l:literals-kw [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/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-parse stx
+ [(_ k:kind-kw d:id-kw l:literals-kw 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/loc stx
- (defform*/subs #:kind kind #:id id #:literals lits [spec] subs desc ...))]
- [(_ #: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 #: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/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 ...))]))
+ (syntax-parse stx
+ [(_ k:kind-kw l:literals-kw spec c:contracts-kw desc ...)
+ (syntax/loc stx
+ (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] ...)
- 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 ...)]))
-
-(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/subs
- (syntax-rules ()
- [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+(define-syntax (spec?form/subs stx)
+ (syntax-parse stx
+ [(_ has-kw? l:literals-kw spec g:grammar
+ c:contracts-kw
desc ...)
- (spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
- desc ...)]
- [(_ spec subs desc ...)
- (specsubform/subs #:literals () spec subs 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 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 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
diff --git a/collects/scribble/private/manual-proc.rkt b/collects/scribble/private/manual-proc.rkt
@@ -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))))))
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -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 ...)]{
