commit 37fe4645d574db0eae19caa95616f5e681727edd
parent 4a93eb50b6d916a866eaef11797d7745be9592b6
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 25 Apr 2010 12:10:36 -0600
change 'define-struct' to bind the type name as a constructor, add an #:extra-constructor-name option, etc.
original commit: 616080c7c4bc10f3f758a198c6e94c394e051038
Diffstat:
7 files changed, 290 insertions(+), 170 deletions(-)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -23,8 +23,9 @@
"private/manual-bib.ss"
"private/manual-form.ss"
"private/manual-class.ss"
- "private/manual-unit.ss"
- "private/manual-vars.ss")
+ "private/manual-unit.ss")
+ (except-out (all-from-out "private/manual-vars.ss")
+ *deftogether)
(except-out (all-from-out "private/manual-proc.ss")
*defthing))
diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss
@@ -25,7 +25,9 @@
specsubform specsubform/subs specspecsubform specspecsubform/subs
specsubform/inline
defsubform defsubform*
- schemegrammar schemegrammar*
+ racketgrammar racketgrammar*
+ (rename-out [racketgrammar schemegrammar]
+ [racketgrammar* schemegrammar*])
var svar)
(define-syntax (defform*/subs stx)
@@ -269,32 +271,32 @@
([form/maybe (#f spec)])
(*specsubform 'spec null #f null null null (lambda () (list desc ...)))))
-(define-syntax schemegrammar
+(define-syntax racketgrammar
(syntax-rules ()
[(_ #:literals (lit ...) id clause ...)
(with-scheme-variables
(lit ...)
([non-term (id clause ...)])
- (*schemegrammar '(lit ...)
+ (*racketgrammar '(lit ...)
'(id clause ...)
(lambda ()
(list (list (scheme id)
(schemeblock0/form clause) ...)))))]
- [(_ id clause ...) (schemegrammar #:literals () id clause ...)]))
+ [(_ id clause ...) (racketgrammar #:literals () id clause ...)]))
-(define-syntax schemegrammar*
+(define-syntax racketgrammar*
(syntax-rules ()
[(_ #:literals (lit ...) [id clause ...] ...)
(with-scheme-variables
(lit ...)
([non-term (id clause ...)] ...)
- (*schemegrammar '(lit ...)
+ (*racketgrammar '(lit ...)
'(id ... clause ... ...)
(lambda ()
(list (list (scheme id) (schemeblock0/form clause) ...)
...))))]
[(_ [id clause ...] ...)
- (schemegrammar* #:literals () [id clause ...] ...)]))
+ (racketgrammar* #:literals () [id clause ...] ...)]))
(define-syntax-rule (var id)
(*var 'id))
@@ -409,7 +411,7 @@
(define (*schemerawgrammar style nonterm clause1 . clauses)
(*schemerawgrammars style (list nonterm) (list (cons clause1 clauses))))
-(define (*schemegrammar lits s-expr clauseses-thunk)
+(define (*racketgrammar lits s-expr clauseses-thunk)
(let ([l (clauseses-thunk)])
(*schemerawgrammars #f
(map (lambda (x)
diff --git a/collects/scribble/private/manual-proc.ss b/collects/scribble/private/manual-proc.ss
@@ -20,7 +20,7 @@
(for-label racket/base
racket/class))
-(provide defproc defproc* defstruct
+(provide defproc defproc* defstruct defstruct*
defparam defparam* defboolparam
defthing defthing*
defthing/proc ; XXX unknown contract
@@ -485,42 +485,90 @@
;; ----------------------------------------
-(define-syntax defstruct
- (syntax-rules ()
- [(_ name fields #:mutable #:inspector #f desc ...)
- (**defstruct name fields #f #t #f desc ...)]
- [(_ name fields #:mutable #:transparent desc ...)
- (**defstruct name fields #f #t #f desc ...)]
- [(_ name fields #:mutable #:prefab desc ...)
- (**defstruct name fields #f #t #t desc ...)]
- [(_ name fields #:mutable desc ...)
- (**defstruct name fields #f #f #f desc ...)]
- [(_ name fields #:inspector #f desc ...)
- (**defstruct name fields #t #t #f desc ...)]
- [(_ name fields #:transparent desc ...)
- (**defstruct name fields #t #t #f desc ...)]
- [(_ name fields #:prefab desc ...)
- (**defstruct name fields #t #t #t desc ...)]
- [(_ name fields desc ...)
- (**defstruct name fields #t #f #f desc ...)]))
+(define-syntax-rule (define-defstruct defstruct default-cname)
+ (...
+ (define-syntax defstruct
+ (syntax-rules ()
+ [(_ name fields #:constructor-name cname #:mutable #:inspector #f desc ...)
+ (**defstruct name fields #f #t #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:mutable #:inspector #f desc ...)
+ (**defstruct name fields #f #t #f cname #t desc ...)]
+ [(_ name fields #:mutable #:inspector #f desc ...)
+ (**defstruct name fields #f #t #f default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname #:mutable #:transparent desc ...)
+ (**defstruct name fields #f #t #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:mutable #:transparent desc ...)
+ (**defstruct name fields #f #t #f cname #t desc ...)]
+ [(_ name fields #:mutable #:transparent desc ...)
+ (**defstruct name fields #f #t #f default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname #:mutable #:prefab desc ...)
+ (**defstruct name fields #f #t #t cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:mutable #:prefab desc ...)
+ (**defstruct name fields #f #t #t cname #t desc ...)]
+ [(_ name fields #:mutable #:prefab desc ...)
+ (**defstruct name fields #f #t #t default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname #:mutable desc ...)
+ (**defstruct name fields #f #f #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:mutable desc ...)
+ (**defstruct name fields #f #f #f cname #t desc ...)]
+ [(_ name fields #:mutable desc ...)
+ (**defstruct name fields #f #f #f default-cname #f desc ...)]
+ [(_ name fields #:constructor-name cname #:inspector #f desc ...)
+ (**defstruct name fields #t #t #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:inspector #f desc ...)
+ (**defstruct name fields #t #t #f cname #t desc ...)]
+ [(_ name fields #:inspector #f desc ...)
+ (**defstruct name fields #t #t #f default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname #:transparent desc ...)
+ (**defstruct name fields #t #t #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:transparent desc ...)
+ (**defstruct name fields #t #t #f cname #t desc ...)]
+ [(_ name fields #:transparent desc ...)
+ (**defstruct name fields #t #t #f default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname #:prefab desc ...)
+ (**defstruct name fields #t #t #t cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname #:prefab desc ...)
+ (**defstruct name fields #t #t #t cname #t desc ...)]
+ [(_ name fields #:prefab desc ...)
+ (**defstruct name fields #t #t #t default-cname #t desc ...)]
+ [(_ name fields #:constructor-name cname desc ...)
+ (**defstruct name fields #t #f #f cname #f desc ...)]
+ [(_ name fields #:extra-constructor-name cname desc ...)
+ (**defstruct name fields #t #f #f cname #t desc ...)]
+ [(_ name fields desc ...)
+ (**defstruct name fields #t #f #f default-cname #t desc ...)]))))
+
+(define-defstruct defstruct #t)
+(define-defstruct defstruct* #f)
(define-syntax-rule (**defstruct name ([field field-contract] ...) immutable?
- transparent? prefab? desc ...)
+ transparent? prefab? cname extra-cname? desc ...)
(with-togetherable-scheme-variables
()
()
- (*defstruct (quote-syntax/loc name) 'name
+ (*defstruct (quote-syntax/loc name) 'name (quote-syntax/loc cname) extra-cname?
'([field field-contract] ...)
(list (lambda () (schemeblock0 field-contract)) ...)
immutable? transparent? prefab? (lambda () (list desc ...)))))
-(define (*defstruct stx-id name fields field-contracts immutable? transparent? prefab?
+(define (*defstruct stx-id name alt-cname-id extra-cname?
+ fields field-contracts immutable? transparent? prefab?
content-thunk)
(define (field-name f) ((if (pair? (car f)) caar car) f))
(define (field-view f)
(if (pair? (car f)) (make-shaped-parens (car f) #\[) (car f)))
- (make-box-splice
- (cons
+ (define cname-id
+ (cond
+ [(identifier? alt-cname-id) alt-cname-id]
+ [(not (syntax-e alt-cname-id)) #f]
+ [else (let ([name-id (if (identifier? stx-id)
+ stx-id
+ (car (syntax-e stx-id)))])
+ (datum->syntax name-id
+ (string->symbol (format "make-~a" (syntax-e name-id)))
+ name-id
+ name-id))]))
+ (define main-table
(make-table
'boxed
(cons
@@ -543,8 +591,10 @@
(list* (list 'info name)
(list 'type 'struct: name)
(list 'predicate name '?)
- (list 'constructor 'make- name)
(append
+ (if cname-id
+ (list (list 'constructor (syntax-e cname-id)))
+ null)
(map (lambda (f)
(list 'accessor name '-
(field-name f)))
@@ -584,96 +634,111 @@
fields)))])
(if (and (short-width . < . max-proto-width)
immutable?
- (not transparent?))
+ (not transparent?)
+ (not cname-id))
(make-omitable-paragraph
(list
(to-element
`(,(scheme struct)
,the-name
,(map field-view fields)))))
- (make-table
- #f
- (append
- (list
- (list (to-flow (make-element #f
- (list
- (schemeparenfont "(")
- (scheme struct))))
- flow-spacer
- (to-flow the-name)
- (if (or (null? fields)
- (short-width . < . max-proto-width))
- flow-spacer
- (to-flow (make-element
- #f (list spacer (schemeparenfont "(")))))
- (to-flow (if (or (null? fields)
- (short-width . < . max-proto-width))
- (make-element
- #f (cons (to-element (map field-view
- fields))
- (if (and immutable?
- (not transparent?))
- (list (schemeparenfont ")"))
- null)))
- (to-element (field-view (car fields)))))))
- (if (short-width . < . max-proto-width)
- null
- (let loop ([fields (if (null? fields)
- fields (cdr fields))])
- (if (null? fields)
+ (let* ([one-right-column?
+ (or (null? fields)
+ (short-width . < . max-proto-width))]
+ [a-right-column
+ (lambda (c)
+ (if one-right-column?
+ (list flow-spacer flow-spacer c)
+ (list flow-spacer flow-spacer c 'cont 'cont)))])
+ (make-table
+ #f
+ (append
+ (list
+ (append
+ (list (to-flow (make-element #f
+ (list
+ (schemeparenfont "(")
+ (scheme struct))))
+ flow-spacer)
+ (if one-right-column?
+ (list (to-flow (make-element
+ #f
+ (list* the-name
+ spacer
+ (to-element (map field-view
+ fields))
+ (if (and immutable?
+ (not transparent?)
+ (not cname-id))
+ (list (schemeparenfont ")"))
+ null)))))
+ (list (to-flow the-name)
+ (to-flow (make-element
+ #f (list spacer (schemeparenfont "("))))
+ (to-flow (to-element (field-view (car fields))))))))
+ (if (short-width . < . max-proto-width)
null
- (cons
- (let ([fld (car fields)])
- (list flow-spacer flow-spacer
- flow-spacer flow-spacer
- (to-flow
- (let ([e (to-element (field-view fld))])
- (if (null? (cdr fields))
- (make-element
- #f
- (list e (schemeparenfont
- (if (and immutable?
- (not transparent?))
- "))" ")"))))
- e)))))
- (loop (cdr fields))))))
- (cond
- [(and (not immutable?) transparent?)
- (list
- (list flow-spacer flow-spacer
- (to-flow (to-element '#:mutable))
- 'cont
- 'cont)
- (list flow-spacer flow-spacer
- (to-flow (make-element
- #f
- (list (if prefab?
- (to-element '#:prefab)
- (to-element '#:transparent))
- (schemeparenfont ")"))))
- 'cont
- 'cont))]
- [(not immutable?)
- (list
- (list flow-spacer flow-spacer
- (to-flow (make-element
- #f
- (list (to-element '#:mutable)
- (schemeparenfont ")"))))
- 'cont
- 'cont))]
- [transparent?
- (list
- (list flow-spacer flow-spacer
- (to-flow (make-element
- #f
- (list (if prefab?
- (to-element '#:prefab)
- (to-element '#:transparent))
- (schemeparenfont ")"))))
- 'cont
- 'cont))]
- [else null]))))))))
+ (let loop ([fields (if (null? fields)
+ fields (cdr fields))])
+ (if (null? fields)
+ null
+ (cons
+ (let ([fld (car fields)])
+ (list flow-spacer flow-spacer
+ flow-spacer flow-spacer
+ (to-flow
+ (let ([e (to-element (field-view fld))])
+ (if (null? (cdr fields))
+ (make-element
+ #f
+ (list e (schemeparenfont
+ (if (and immutable?
+ (not transparent?)
+ (not cname-id))
+ "))"
+ ")"))))
+ e)))))
+ (loop (cdr fields))))))
+ (if cname-id
+ (list (a-right-column
+ (to-flow (make-element
+ #f
+ (append
+ (list (to-element (if extra-cname?
+ '#:extra-constructor-name
+ '#:constructor-name))
+ (hspace 1)
+ (to-element cname-id))
+ (if (and immutable?
+ (not transparent?))
+ (list (schemeparenfont ")"))
+ null))))))
+ null)
+ (cond
+ [(and (not immutable?) transparent?)
+ (list
+ (a-right-column (to-flow (to-element '#:mutable)))
+ (a-right-column (to-flow (make-element
+ #f
+ (list (if prefab?
+ (to-element '#:prefab)
+ (to-element '#:transparent))
+ (schemeparenfont ")"))))))]
+ [(not immutable?)
+ (list
+ (a-right-column (to-flow (make-element
+ #f
+ (list (to-element '#:mutable)
+ (schemeparenfont ")"))))))]
+ [transparent?
+ (list
+ (a-right-column (to-flow (make-element
+ #f
+ (list (if prefab?
+ (to-element '#:prefab)
+ (to-element '#:transparent))
+ (schemeparenfont ")"))))))]
+ [else null])))))))))
(map (lambda (v field-contract)
(cond
[(pair? v)
@@ -688,7 +753,10 @@
flow-spacer
(make-flow (list (field-contract))))))))]
[else null]))
- fields field-contracts)))
+ fields field-contracts))))
+ (make-box-splice
+ (cons
+ main-table
(content-thunk))))
;; ----------------------------------------
@@ -709,49 +777,87 @@
(list (schemeblock0 result) ...)
(lambda () (list desc ...)))))
-(define (*defthing stx-ids names form? result-contracts content-thunk)
+(define (*defthing stx-ids names form? result-contracts content-thunk
+ [result-values (map (lambda (x) #f) result-contracts)])
(make-box-splice
(cons
(make-table
'boxed
(map
- (lambda (stx-id name result-contract)
+ (lambda (stx-id name result-contract result-value)
(list
(make-flow
(make-table-if-necessary
"argcontract"
- (list
+ (let* ([result-block
+ (and result-value
+ (if (block? result-value)
+ result-value
+ (make-omitable-paragraph (list result-value))))]
+ [contract-block
+ (if (block? result-contract)
+ result-contract
+ (make-omitable-paragraph (list result-contract)))]
+ [total-width (+ (string-length (format "~a" name))
+ 3
+ (block-width contract-block)
+ (if result-block
+ (+ (block-width result-block) 3)
+ 0))])
+ (append
(list
- (make-flow
+ (append
(list
- (make-omitable-paragraph
+ (make-flow
(list
- (let ([target-maker
- ((if form? id-to-form-target-maker id-to-target-maker)
- stx-id #t)]
- [content (list (definition-site name stx-id form?))])
- (if target-maker
- (target-maker
- content
- (lambda (tag)
- (make-toc-target-element
- #f
- (list
- (make-index-element
- #f
- content
- tag
- (list (symbol->string name))
- content
- (with-exporting-libraries
- (lambda (libs) (make-thing-index-desc name libs)))))
- tag)))
- (car content)))
- spacer ":" spacer))))
- (make-flow (list (if (block? result-contract)
- result-contract
- (make-omitable-paragraph (list result-contract)))))))))))
- stx-ids names result-contracts))
+ (make-omitable-paragraph
+ (list
+ (let ([target-maker
+ ((if form? id-to-form-target-maker id-to-target-maker)
+ stx-id #t)]
+ [content (list (definition-site name stx-id form?))])
+ (if target-maker
+ (target-maker
+ content
+ (lambda (tag)
+ (make-toc-target-element
+ #f
+ (list
+ (make-index-element
+ #f
+ content
+ tag
+ (list (symbol->string name))
+ content
+ (with-exporting-libraries
+ (lambda (libs) (make-thing-index-desc name libs)))))
+ tag)))
+ (car content)))))))
+ (make-flow
+ (list
+ (make-omitable-paragraph
+ (list
+ spacer ":" spacer))))
+ (make-flow (list contract-block)))
+ (if (and result-value
+ (total-width . < . 60))
+ (list
+ (to-flow (make-element #f (list spacer "=" spacer)))
+ (make-flow (list result-block)))
+ null)))
+ (if (and result-value
+ (total-width . >= . 60))
+ (list
+ (list
+ (make-table-if-necessary
+ "argcontract"
+ (list
+ (list flow-spacer
+ (to-flow (make-element #f (list spacer "=" spacer)))
+ (make-flow (list result-block)))))
+ 'cont))
+ null)))))))
+ stx-ids names result-contracts result-values))
(content-thunk))))
(define (defthing/proc id contract descs)
diff --git a/collects/scribble/private/manual-vars.ss b/collects/scribble/private/manual-vars.ss
@@ -14,7 +14,7 @@
(provide/contract
[struct (box-splice splice) ([run list?])]) ; XXX ugly copying
-(provide deftogether
+(provide deftogether *deftogether
with-scheme-variables
with-togetherable-scheme-variables)
@@ -109,7 +109,7 @@
(define (*deftogether boxes body-thunk)
- (make-splice
+ (make-box-splice
(cons
(make-table
'boxed
diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss
@@ -34,12 +34,14 @@
(let ([v (read i)])
(and (eof-object? (read i)) v)))))
+(current-render-mixin html:render-mixin)
+
(define (run)
(command-line
#:program (short-program+command-name)
#:once-any
[("--text") "generate text-format output (the default)"
- (void)]
+ (current-render-mixin text:render-mixin)]
[("--html") "generate HTML-format output file"
(current-render-mixin html:render-mixin)]
[("--htmls") "generate HTML-format output directory"
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
@@ -617,19 +617,28 @@ Like @scheme[defparam], but the contract on a parameter argument is
Like @scheme[defproc], but for a non-procedure binding.}
-
-@defform/subs[(defstruct struct-name ([field-name contract-expr-datum] ...)
- flag-keywords
- pre-flow ...)
- ([struct-name id
- (id super-id)]
- [flag-keywords code:blank
- #:mutable
- (code:line #:inspector #f)
- (code:line #:mutable #:inspector #f)])]{
+@deftogether[(
+@defform[ (defstruct* struct-name ([field-name contract-expr-datum] ...)
+ maybe-mutable maybe-non-opaque maybe-constructor
+ pre-flow ...)]
+@defform/subs[ (defstruct struct-name ([field-name contract-expr-datum] ...)
+ maybe-mutable maybe-non-opaque maybe-constructor
+ pre-flow ...)
+ ([struct-name id
+ (id super-id)]
+ [maybe-mutable code:blank
+ #:mutable]
+ [maybe-non-opaque code:blank
+ #:prefab
+ #:transparent]
+ [maybe-constructor code:blank
+ (code:line #:constructor-name constructor-id)
+ (code:line #:extra-constructor-name constructor-id)])]
+)]{
Similar to @scheme[defform] or @scheme[defproc], but for a structure
-definition.}
+definition. The @scheme[defstruct*] form corresponds to @scheme[struct],
+while @scheme[defstruct] corresponds to @scheme[define-struct].}
@defform[(deftogether [def-expr ...] pre-flow ...)]{
diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss
@@ -1,9 +1,9 @@
-#lang scheme/base
+#lang racket/base
(require scribble/core
scribble/html-properties
scribble/manual
- (prefix-in scheme: scribble/scheme)
+ (prefix-in racket: scribble/racket)
(prefix-in scribble: scribble/reader))
(define-syntax bounce-for-label
@@ -15,12 +15,12 @@
(provide (for-label (all-from-out mod))))]
[(_ mod ...) (begin (bounce-for-label mod) ...)]))
-(bounce-for-label (all-except scheme (link) ())
+(bounce-for-label (all-except racket (link) ())
scribble/core
scribble/base-render
scribble/decode
scribble/manual
- scribble/scheme
+ scribble/racket
scribble/html-properties
scribble/latex-properties
scribble/eval
@@ -94,7 +94,7 @@
(map (lambda (x)
(let ([@expr (if x (litchar/lines (car x)) "")]
[sexpr (if x
- (scheme:to-paragraph
+ (racket:to-paragraph
((norm-spacing 0) (cadr x)))
"")]
[reads-as (if x reads-as "")])
@@ -103,7 +103,7 @@
;; stuff for the preprocessor examples
-(require scheme/list (for-syntax scheme/base scheme/list))
+(require racket/list (for-syntax racket/base racket/list))
(define max-textsample-width 45)
