From 322be283e39e591da633ed4ea31d060d115d9611 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Jan 2009 14:00:07 +0000 Subject: [PATCH] add #:contracts optional sub-form to defform svn: r13012 original commit: 851c58ea50dc31c175bde7016962833f379885c6 --- collects/scribble/private/manual-form.ss | 135 +++++++++++++++------ collects/scribblings/scribble/manual.scrbl | 39 ++++-- 2 files changed, 129 insertions(+), 45 deletions(-) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 76ffc103..8b348a6b 100644 --- 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 index 3518eb12..535ce73e 100644 --- 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