commit 322be283e39e591da633ed4ea31d060d115d9611
parent e296df047113e642425c40293050f281b52dd226
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 5 Jan 2009 14:00:07 +0000
add #:contracts optional sub-form to defform
svn: r13012
original commit: 851c58ea50dc31c175bde7016962833f379885c6
Diffstat:
2 files changed, 129 insertions(+), 45 deletions(-)
diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss
@@ -32,6 +32,7 @@
(syntax-case stx ()
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
+ #:contracts ([contract-nonterm contract-expr] ...)
desc ...)
(with-syntax ([new-spec
(let loop ([spec #'spec])
@@ -65,57 +66,83 @@
(lambda () (schemeblock0/form non-term-form))
...)
...)
+ (list (list (lambda () (scheme contract-nonterm))
+ (lambda () (schemeblock0 contract-expr)))
+ ...)
(lambda () (list 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 #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...)
- #'(fm #:id id #:literals () [spec spec1 ...]
+ (syntax/loc stx
+ (fm #:id id #:literals () [spec spec1 ...]
([non-term-id non-term-form ...] ...)
- desc ...)]
+ #:contracts ()
+ desc ...))]
[(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(with-syntax ([(_ _ _ [spec . _] . _) stx])
- #'(fm #:id spec-id #:literals lits [spec spec1 ...]
+ (syntax/loc stx
+ (fm #:id spec-id #:literals lits [spec spec1 ...]
([non-term-id non-term-form ...] ...)
- desc ...))]
+ desc ...)))]
[(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
- #'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
- desc ...)]))
+ (syntax/loc stx
+ (fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
+ desc ...))]))
(define-syntax (defform* stx)
(syntax-case stx ()
[(_ #:id id #:literals lits [spec ...] desc ...)
- #'(defform*/subs #:id id #:literals lits [spec ...] () desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:id id #:literals lits [spec ...] () desc ...))]
[(_ #:literals lits [spec ...] desc ...)
- #'(defform*/subs #:literals lits [spec ...] () desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:literals lits [spec ...] () desc ...))]
[(_ [spec ...] desc ...)
- #'(defform*/subs [spec ...] () desc ...)]))
+ (syntax/loc stx
+ (defform*/subs [spec ...] () desc ...))]))
(define-syntax (defform stx)
(syntax-case stx ()
[(_ #:id id #:literals (lit ...) spec desc ...)
- #'(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))]
[(_ #:id id spec desc ...)
- #'(defform*/subs #:id id #:literals () [spec] () desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:id id #:literals () [spec] () desc ...))]
[(_ #:literals (lit ...) spec desc ...)
- #'(defform*/subs #:literals (lit ...) [spec] () desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:literals (lit ...) [spec] () desc ...))]
[(_ spec desc ...)
- #'(defform*/subs [spec] () desc ...)]))
+ (syntax/loc stx
+ (defform*/subs [spec] () desc ...))]))
(define-syntax (defform/subs stx)
(syntax-case stx ()
[(_ #:id id #:literals lits spec subs desc ...)
- #'(defform*/subs #:id id #:literals lits [spec] subs desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:id id #:literals lits [spec] subs desc ...))]
[(_ #:id id spec subs desc ...)
- #'(defform*/subs #:id id #:literals () [spec] subs desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:id id #:literals () [spec] subs desc ...))]
[(_ #:literals lits spec subs desc ...)
- #'(defform*/subs #:literals lits [spec] subs desc ...)]
+ (syntax/loc stx
+ (defform*/subs #:literals lits [spec] subs desc ...))]
[(_ spec subs desc ...)
- #'(defform*/subs [spec] subs desc ...)]))
+ (syntax/loc stx
+ (defform*/subs [spec] subs desc ...))]))
(define-syntax (defform/none stx)
(syntax-case stx ()
- [(_ #:literals (lit ...) spec desc ...)
+ [(_ #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
(begin
(for-each (lambda (id)
(unless (identifier? id)
@@ -130,9 +157,16 @@
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
+ (list (list (lambda () (scheme contract-id))
+ (lambda () (schemeblock0 contract-expr)))
+ ...)
(lambda () (list desc ...)))))]
- [(_ spec desc ...)
- #'(defform/none #:literals () spec desc ...)]))
+ [(fm #:literals (lit ...) spec desc ...)
+ (syntax/loc stx
+ (fm #:literals (lit ...) spec #:contracts () desc ...))]
+ [(fm spec desc ...)
+ (syntax/loc stx
+ (fm #:literals () spec desc ...))]))
(define-syntax (defidform stx)
(syntax-case stx ()
@@ -145,6 +179,7 @@
(list (lambda (x) (make-omitable-paragraph (list x))))
null
null
+ null
(lambda () (list desc ...))))]))
(define (into-blockquote s)
@@ -164,6 +199,7 @@
(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-scheme-variables
(lit ...)
@@ -175,7 +211,15 @@
(lambda () (schemeblock0/form non-term-form))
...)
...)
- (lambda () (list desc ...))))]))
+ (list (list (lambda () (scheme contract-nonterm))
+ (lambda () (schemeblock0 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 ()
@@ -220,7 +264,7 @@
(with-scheme-variables
()
([form/maybe (#f spec)])
- (*specsubform 'spec null #f null null (lambda () (list desc ...)))))
+ (*specsubform 'spec null #f null null null (lambda () (list desc ...)))))
(define-syntax schemegrammar
(syntax-rules ()
@@ -258,7 +302,7 @@
(define (meta-symbol? s) (memq s '(... ...+ ?)))
-(define (*defforms kw-id forms form-procs subs sub-procs content-thunk)
+(define (*defforms kw-id forms form-procs subs sub-procs contract-procs content-thunk)
(parameterize ([current-meta-list '(... ...+)])
(make-box-splice
(cons
@@ -307,10 +351,11 @@
sub-procs)])
(*schemerawgrammars "specgrammar"
(map car l)
- (map cdr l))))))))))
+ (map cdr l))))))))
+ (make-contracts-table contract-procs)))
(content-thunk)))))
-(define (*specsubform form lits form-thunk subs sub-procs content-thunk)
+(define (*specsubform form lits form-thunk subs sub-procs contract-procs content-thunk)
(parameterize ([current-meta-list '(... ...+)])
(make-blockquote
"leftindent"
@@ -324,16 +369,18 @@
(if form-thunk
(form-thunk)
(make-omitable-paragraph (list (to-element form)))))))
- (if (null? sub-procs)
- null
- (list (list flow-empty-line)
- (list (make-flow
- (list (let ([l (map (lambda (sub)
- (map (lambda (f) (f)) sub))
- sub-procs)])
- (*schemerawgrammars "specgrammar"
- (map car l)
- (map cdr l))))))))))
+ (append
+ (if (null? sub-procs)
+ null
+ (list (list flow-empty-line)
+ (list (make-flow
+ (list (let ([l (map (lambda (sub)
+ (map (lambda (f) (f)) sub))
+ sub-procs)])
+ (*schemerawgrammars "specgrammar"
+ (map car l)
+ (map cdr l))))))))
+ (make-contracts-table contract-procs))))
(flow-paragraphs (decode-flow (content-thunk)))))))
(define (*schemerawgrammars style nonterms clauseses)
@@ -374,3 +421,21 @@
(define (*var-sym id)
(string->symbol (format "_~a" id)))
+
+(define (make-contracts-table contract-procs)
+ (if (null? contract-procs)
+ null
+ (append
+ (list (list flow-empty-line))
+ (list (list (make-flow
+ (map (lambda (c)
+ (make-table
+ "argcontract"
+ (list
+ (list (to-flow (hspace 2))
+ (to-flow ((car c)))
+ flow-spacer
+ (to-flow ":")
+ flow-spacer
+ (make-flow (list ((cadr c))))))))
+ contract-procs)))))))
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -387,15 +387,19 @@ can also be defined by a single @scheme[defproc*], for the case that
it's best to document a related group of procedures at once.}
-@defform/subs[(defform maybe-id maybe-literals form-datum pre-flow ...)
+@defform/subs[(defform maybe-id maybe-literals form-datum maybe-contracts
+ pre-flow ...)
([maybe-id code:blank
(code:line #:id id)]
[maybe-literals code:blank
- (code:line #:literals (literal-id ...))])]{
+ (code:line #:literals (literal-id ...))]
+ [maybe-contracts code:blank
+ (code:line #:contracts ([subform-datum contract-expr-datum]
+ ...))])]{
Produces a sequence of flow elements (encapsulated in a
@scheme[splice]) to document a syntatic form named by @scheme[id]
-whose syntax described by @scheme[form-datum]. If no @scheme[#:id] is used
+whose syntax is described by @scheme[form-datum]. If no @scheme[#:id] is used
to specify @scheme[id], then @scheme[form-datum] must have the form
@scheme[(id . _datum)].
@@ -414,16 +418,24 @@ non-terminal. If @scheme[#:literals] clause is provided, however,
instances of the @scheme[literal-id]s are typeset normally (i.e., as
determined by the enclosing context).
-The typesetting of @scheme[form-datum] preserves the source layout,
-like @scheme[schemeblock].}
+If a @scheme[#:contracts] clause is provided, each
+@scheme[subform-datum] (typically an identifier that serves as a
+meta-variable in @scheme[form-datum]) is shown as producing a value
+that must satisfy the contract described by @scheme[contract-expr-datum].
-@defform[(defform* maybe-id maybe-literals [form-datum ...+] pre-flow ...)]{
+The typesetting of @scheme[form-datum], @scheme[subform-datum], and
+@scheme[contract-expr-datum] preserves the source layout, like
+@scheme[schemeblock].}
+
+@defform[(defform* maybe-id maybe-literals [form-datum ...+] maybe-contracts
+ pre-flow ...)]{
Like @scheme[defform], but for multiple forms using the same
@scheme[_id].}
@defform[(defform/subs maybe-id maybe-literals form-datum
([nonterm-id clause-datum ...+] ...)
+ maybe-contracts
pre-flow ...)]{
Like @scheme[defform], but including an auxiliary grammar of
@@ -434,12 +446,14 @@ non-terminals shown with the @scheme[_id] form. Each
@defform[(defform*/subs maybe-id maybe-literals [form-datum ...]
+ maybe-contracts
pre-flow ...)]{
Like @scheme[defform/subs], but for multiple forms for @scheme[_id].}
-@defform[(defform/none maybe-literal form-datum pre-flow ...)]{
+@defform[(defform/none maybe-literal form-datum maybe-contracts
+ pre-flow ...)]{
Like @scheme[defform], but without registering a definition.}
@@ -449,14 +463,16 @@ Like @scheme[defform], but without registering a definition.}
Like @scheme[defform], but with a plain @scheme[id] as the form.}
-@defform[(specform maybe-literals datum pre-flow ...)]{
+@defform[(specform maybe-literals datum maybe-contracts
+ pre-flow ...)]{
Like @scheme[defform], but without indexing or registering a
definition, and with indenting on the left for both the specification
and the @scheme[pre-flow]s.}
-@defform[(specsubform maybe-literals datum pre-flow ...)]{
+@defform[(specsubform maybe-literals datum maybe-contracts
+ pre-flow ...)]{
Similar to @scheme[defform], but without any specific identifier being
defined, and the table and flow are typeset indented. This form is
@@ -472,13 +488,15 @@ procedure. In this description, a reference to any identifier in
@defform[(specsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...)
+ maybe-contracts
pre-flow ...)]{
Like @scheme[specsubform], but with a grammar like
@scheme[defform/subs].}
-@defform[(specspecsubform maybe-literals datum pre-flow ...)]{
+@defform[(specspecsubform maybe-literals datum maybe-contracts
+ pre-flow ...)]{
Like @scheme[specsubform], but indented an extra level. Since using
@scheme[specsubform] within the body of @scheme[specsubform] already
@@ -488,6 +506,7 @@ without nesting a description.}
@defform[(specspecsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...)
+ maybe-contracts
pre-flow ...)]{
Like @scheme[specspecsubform], but with a grammar like
