scribble: adjust `def...' box to show a background label in HTML
For example, a syntactic form box is labeled with "SYNTAX". Forms such as `defform' and `defthing' now support a `#:kind' option for setting the label. original commit: 5ff3087677ec98ea626cca25b085f3c32138d5ca
This commit is contained in:
Matthew Flatt
parent
f1aa676101
commit
4fc0b01398
|
|
@ -141,8 +141,13 @@
|
|||
(style-properties style)))])
|
||||
(let ([name (style-name style)])
|
||||
(if (string? name)
|
||||
(cons `[class ,name]
|
||||
a)
|
||||
(if (assq 'class a)
|
||||
(for/list ([i (in-list a)])
|
||||
(if (eq? (car i) 'class)
|
||||
(list 'class (string-append name " " (cadr i)))
|
||||
i))
|
||||
(cons `[class ,name]
|
||||
a))
|
||||
a))))
|
||||
|
||||
;; combine a 'class attribute from both cl and al
|
||||
|
|
@ -681,7 +686,8 @@
|
|||
css-addition-path)
|
||||
(list style-file)
|
||||
style-extra-files))
|
||||
,(scribble-js-contents script-file (lookup-path script-file alt-paths)))
|
||||
,(scribble-js-contents script-file (lookup-path script-file alt-paths))
|
||||
,(xml:comment "[if IE 6]><style type=\"text/css\">.SIEHidden { overflow: hidden; }</style><![endif]"))
|
||||
(body ([id ,(or (extract-part-body-id d ri)
|
||||
"scribble-racket-lang-org")])
|
||||
,@(render-toc-view d ri)
|
||||
|
|
@ -1316,19 +1322,20 @@
|
|||
(extract-table-cell-styles t))))))
|
||||
|
||||
(define/override (render-nested-flow t part ri starting-item?)
|
||||
`((blockquote [,@(combine-class
|
||||
(cond
|
||||
[(eq? 'code-inset (style-name (nested-flow-style t)))
|
||||
`([class "SCodeFlow"])]
|
||||
[(eq? 'vertical-inset (style-name (nested-flow-style t)))
|
||||
`([class "SVInsetFlow"])]
|
||||
[(and (not (string? (style-name (nested-flow-style t))))
|
||||
(not (eq? 'inset (style-name (nested-flow-style t)))))
|
||||
`([class "SubFlow"])]
|
||||
[else null])
|
||||
(style->attribs (nested-flow-style t)))]
|
||||
,@(apply append
|
||||
(super render-nested-flow t part ri starting-item?)))))
|
||||
`((,(or (style->tag (nested-flow-style t)) 'blockquote)
|
||||
[,@(combine-class
|
||||
(cond
|
||||
[(eq? 'code-inset (style-name (nested-flow-style t)))
|
||||
`([class "SCodeFlow"])]
|
||||
[(eq? 'vertical-inset (style-name (nested-flow-style t)))
|
||||
`([class "SVInsetFlow"])]
|
||||
[(and (not (string? (style-name (nested-flow-style t))))
|
||||
(not (eq? 'inset (style-name (nested-flow-style t)))))
|
||||
`([class "SubFlow"])]
|
||||
[else null])
|
||||
(style->attribs (nested-flow-style t)))]
|
||||
,@(apply append
|
||||
(super render-nested-flow t part ri starting-item?)))))
|
||||
|
||||
(define/override (render-compound-paragraph t part ri starting-item?)
|
||||
(let ([style (compound-paragraph-style t)])
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
"manual-bind.rkt"
|
||||
"manual-method.rkt"
|
||||
"manual-proc.rkt"
|
||||
"manual-vars.rkt"
|
||||
scheme/list
|
||||
(for-syntax scheme/base)
|
||||
(for-label scheme/base
|
||||
|
|
@ -187,39 +188,41 @@
|
|||
|
||||
(define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc)
|
||||
(make-table
|
||||
'boxed
|
||||
boxed-style
|
||||
(append
|
||||
(list
|
||||
(list (make-flow
|
||||
(list
|
||||
(make-omitable-paragraph
|
||||
(list (let ([target-maker (id-to-target-maker stx-id #t)]
|
||||
[content (list (annote-exporting-library
|
||||
(to-element stx-id)))])
|
||||
(if target-maker
|
||||
(target-maker
|
||||
content
|
||||
(lambda (tag)
|
||||
((if whole-page?
|
||||
(list
|
||||
((add-background-label (symbol->string kind))
|
||||
(make-flow
|
||||
(list
|
||||
(make-omitable-paragraph
|
||||
(list (let ([target-maker (id-to-target-maker stx-id #t)]
|
||||
[content (list (annote-exporting-library
|
||||
(to-element stx-id)))])
|
||||
(if target-maker
|
||||
(target-maker
|
||||
content
|
||||
(lambda (tag)
|
||||
((if whole-page?
|
||||
make-page-target-element
|
||||
make-toc-target-element)
|
||||
#f
|
||||
(list
|
||||
(make-index-element
|
||||
#f content tag
|
||||
(list (datum-intern-literal
|
||||
(symbol->string (syntax-e stx-id))))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-index-desc (syntax-e stx-id) libs)))))
|
||||
tag)))
|
||||
(car content)))
|
||||
spacer ":" spacer
|
||||
(case kind
|
||||
[(class) (racket class?)]
|
||||
[(interface) (racket interface?)]
|
||||
[(mixin) (racketblockelem (class? . -> . class?))])))))))
|
||||
#f
|
||||
(list
|
||||
(make-index-element
|
||||
#f content tag
|
||||
(list (datum-intern-literal
|
||||
(symbol->string (syntax-e stx-id))))
|
||||
content
|
||||
(with-exporting-libraries
|
||||
(lambda (libs)
|
||||
(make-index-desc (syntax-e stx-id) libs)))))
|
||||
tag)))
|
||||
(car content)))
|
||||
spacer ":" spacer
|
||||
(case kind
|
||||
[(class) (racket class?)]
|
||||
[(interface) (racket interface?)]
|
||||
[(mixin) (racketblockelem (class? . -> . class?))]))))))))
|
||||
(if super
|
||||
(list
|
||||
(list (make-flow
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
|
||||
(define-syntax (defform*/subs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
[(_ #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ([contract-nonterm contract-expr] ...)
|
||||
desc ...)
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
(lit ...)
|
||||
([form [defined-id spec]] [form [defined-id spec1]] ...
|
||||
[non-term (non-term-id non-term-form ...)] ...)
|
||||
(*defforms defined-id-expr
|
||||
(*defforms kind defined-id-expr
|
||||
'(spec spec1 ...)
|
||||
(list (lambda (x) (racketblock0/form new-spec))
|
||||
(lambda (ignored) (racketblock0/form spec1)) ...)
|
||||
|
|
@ -70,6 +70,15 @@
|
|||
(lambda () (racketblock0 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 ...)
|
||||
|
|
@ -78,74 +87,130 @@
|
|||
([non-term-id non-term-form ...] ...)
|
||||
#:contracts ()
|
||||
desc ...))]
|
||||
[(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
[(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
|
||||
([non-term-id non-term-form ...] ...)
|
||||
desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:id id #:literals () [spec spec1 ...]
|
||||
(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 #:id spec-id #:literals lits [spec spec1 ...]
|
||||
(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 #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
(fm #:kind #f #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
|
||||
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/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 ...))]))
|
||||
|
||||
(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/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 ...))]))
|
||||
|
||||
(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/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 ...))]))
|
||||
|
||||
(define-syntax (defform/none stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
|
||||
[(_ #:kind kind #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
|
||||
(begin
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
|
|
@ -157,16 +222,25 @@
|
|||
#'(with-togetherable-racket-variables
|
||||
(lit ...)
|
||||
([form/none spec])
|
||||
(*defforms #f
|
||||
(*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 ...))]))
|
||||
|
|
@ -181,17 +255,20 @@
|
|||
|
||||
(define-syntax (defidform stx)
|
||||
(syntax-case stx ()
|
||||
[(_ spec-id desc ...)
|
||||
[(_ #:kind kind spec-id desc ...)
|
||||
#'(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defforms (quote-syntax/loc spec-id)
|
||||
(*defforms kind (quote-syntax/loc spec-id)
|
||||
'(spec-id)
|
||||
(list (lambda (x) (make-omitable-paragraph (list x))))
|
||||
null
|
||||
null
|
||||
null
|
||||
(lambda () (list desc ...))))]))
|
||||
(lambda () (list desc ...))))]
|
||||
[(fm spec-id desc ...)
|
||||
(syntax/loc stx
|
||||
(fm #:kind #f spec-id desc ...))]))
|
||||
|
||||
(define (into-blockquote s)
|
||||
(make-blockquote "leftindent"
|
||||
|
|
@ -336,7 +413,7 @@
|
|||
tag)))
|
||||
(car content))))
|
||||
|
||||
(define (*defforms kw-id forms form-procs subs sub-procs contract-procs content-thunk)
|
||||
(define (*defforms kind kw-id forms form-procs subs sub-procs contract-procs content-thunk)
|
||||
(parameterize ([current-meta-list '(... ...+)])
|
||||
(make-box-splice
|
||||
(cons
|
||||
|
|
@ -346,19 +423,19 @@
|
|||
(make-table
|
||||
boxed-style
|
||||
(append
|
||||
(map
|
||||
(lambda (form form-proc)
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
((or form-proc
|
||||
(lambda (x)
|
||||
(make-omitable-paragraph
|
||||
(list (to-element `(,x . ,(cdr form)))))))
|
||||
(and kw-id
|
||||
(eq? form (car forms))
|
||||
(defform-site kw-id)))))))
|
||||
forms form-procs)
|
||||
(for/list ([form (in-list forms)]
|
||||
[form-proc (in-list form-procs)]
|
||||
[i (in-naturals)])
|
||||
(list
|
||||
((if (zero? i) (add-background-label (or kind "syntax")) values)
|
||||
(list
|
||||
((or form-proc
|
||||
(lambda (x)
|
||||
(make-omitable-paragraph
|
||||
(list (to-element `(,x . ,(cdr form)))))))
|
||||
(and kw-id
|
||||
(eq? form (car forms))
|
||||
(defform-site kw-id)))))))
|
||||
(if (null? sub-procs)
|
||||
null
|
||||
(list (list flow-empty-line)
|
||||
|
|
|
|||
|
|
@ -113,29 +113,38 @@
|
|||
"expected a result contract, found a string" #'c)
|
||||
#'(racketblock0 c))]))
|
||||
|
||||
(define-syntax-rule (defproc (id arg ...) result desc ...)
|
||||
(defproc* [[(id arg ...) result]] desc ...))
|
||||
(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 ...)]))
|
||||
|
||||
(define-syntax defproc*
|
||||
(syntax-rules ()
|
||||
[(_ [[proto result] ...] desc ...)
|
||||
(defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
|
||||
[(_ #:mode m #:within cl [[proto result] ...] desc ...)
|
||||
[(_ #:kind kind #:mode m #:within cl [[proto result] ...] desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
([proc proto] ...)
|
||||
(*defproc 'm (quote-syntax/loc cl)
|
||||
(*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 ...))))]))
|
||||
(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-struct arg
|
||||
(special? kw id optional? starts-optional? ends-optional? num-closers))
|
||||
|
||||
(define (*defproc mode within-id
|
||||
(define (*defproc kind mode within-id
|
||||
stx-ids prototypes arg-contractss arg-valss result-contracts
|
||||
content-thunk)
|
||||
(define max-proto-width (current-display-width))
|
||||
|
|
@ -336,91 +345,97 @@
|
|||
. >= . (- max-proto-width 7)))
|
||||
(define end (list flow-spacer (to-flow 'rarr)
|
||||
flow-spacer (make-flow (list res))))
|
||||
(define (get-label)
|
||||
(case mode
|
||||
[(new make) "constructor"]
|
||||
[(send) "method"]
|
||||
[else (or kind "procedure")]))
|
||||
(append
|
||||
(list
|
||||
(list
|
||||
(make-flow
|
||||
(if short?
|
||||
;; The single-line case:
|
||||
(make-table-if-necessary
|
||||
"prototype"
|
||||
(list
|
||||
(cons
|
||||
(to-flow
|
||||
(make-element
|
||||
#f
|
||||
`(,(make-openers (add1 p-depth))
|
||||
,tagged
|
||||
,@(if (null? args)
|
||||
(list (make-closers p-depth))
|
||||
(append-map (lambda (arg)
|
||||
(list spacer ((arg->elem #t) arg)))
|
||||
args))
|
||||
,(racketparenfont ")"))))
|
||||
(if result-next-line? null end))))
|
||||
;; The multi-line case:
|
||||
(let ([not-end (if result-next-line?
|
||||
(list flow-spacer)
|
||||
(list flow-spacer flow-spacer
|
||||
flow-spacer flow-spacer))]
|
||||
[one-ok? (and (not (eq? mode 'new)) (tagged+arg-width . < . 60))])
|
||||
(list
|
||||
(make-table
|
||||
((if first? (add-background-label (get-label)) values)
|
||||
(make-flow
|
||||
(if short?
|
||||
;; The single-line case:
|
||||
(make-table-if-necessary
|
||||
"prototype"
|
||||
(cons
|
||||
(list
|
||||
(cons
|
||||
(to-flow
|
||||
(make-element
|
||||
#f
|
||||
(list
|
||||
(make-openers (add1 p-depth))
|
||||
tagged)))
|
||||
(if one-ok?
|
||||
(list*
|
||||
(if (arg-starts-optional? (car args))
|
||||
(to-flow (make-element #f (list spacer "[")))
|
||||
flow-spacer)
|
||||
(to-flow ((arg->elem #f) (car args)))
|
||||
not-end)
|
||||
(list* 'cont 'cont not-end)))
|
||||
(let loop ([args (if one-ok? (cdr args) args)])
|
||||
(if (null? args)
|
||||
null
|
||||
(let ([dots-next?
|
||||
(or (and (pair? (cdr args))
|
||||
(arg-special? (cadr args))
|
||||
(not (eq? '_...superclass-args...
|
||||
(arg-id (cadr args))))))])
|
||||
(cons
|
||||
(list*
|
||||
(if (eq? mode 'new)
|
||||
(flow-spacer/n 3)
|
||||
flow-spacer)
|
||||
(if (arg-starts-optional? (car args))
|
||||
(to-flow (make-element #f (list spacer "[")))
|
||||
flow-spacer)
|
||||
(let ([a ((arg->elem #f) (car args))]
|
||||
[next (if dots-next?
|
||||
(make-element
|
||||
#f (list spacer
|
||||
((arg->elem #f)
|
||||
(cadr args))))
|
||||
"")])
|
||||
(to-flow
|
||||
(cond
|
||||
[(null? ((if dots-next? cddr cdr) args))
|
||||
(make-element
|
||||
#f
|
||||
(list a next (racketparenfont ")")))]
|
||||
[(equal? next "") a]
|
||||
[else
|
||||
(make-element #f (list a next))])))
|
||||
(if (and (null? ((if dots-next? cddr cdr) args))
|
||||
(not result-next-line?))
|
||||
end
|
||||
not-end))
|
||||
(loop ((if dots-next? cddr cdr)
|
||||
args))))))))))))))
|
||||
`(,(make-openers (add1 p-depth))
|
||||
,tagged
|
||||
,@(if (null? args)
|
||||
(list (make-closers p-depth))
|
||||
(append-map (lambda (arg)
|
||||
(list spacer ((arg->elem #t) arg)))
|
||||
args))
|
||||
,(racketparenfont ")"))))
|
||||
(if result-next-line? null end))))
|
||||
;; The multi-line case:
|
||||
(let ([not-end (if result-next-line?
|
||||
(list flow-spacer)
|
||||
(list flow-spacer flow-spacer
|
||||
flow-spacer flow-spacer))]
|
||||
[one-ok? (and (not (eq? mode 'new)) (tagged+arg-width . < . 60))])
|
||||
(list
|
||||
(make-table
|
||||
"prototype"
|
||||
(cons
|
||||
(cons
|
||||
(to-flow
|
||||
(make-element
|
||||
#f
|
||||
(list
|
||||
(make-openers (add1 p-depth))
|
||||
tagged)))
|
||||
(if one-ok?
|
||||
(list*
|
||||
(if (arg-starts-optional? (car args))
|
||||
(to-flow (make-element #f (list spacer "[")))
|
||||
flow-spacer)
|
||||
(to-flow ((arg->elem #f) (car args)))
|
||||
not-end)
|
||||
(list* 'cont 'cont not-end)))
|
||||
(let loop ([args (if one-ok? (cdr args) args)])
|
||||
(if (null? args)
|
||||
null
|
||||
(let ([dots-next?
|
||||
(or (and (pair? (cdr args))
|
||||
(arg-special? (cadr args))
|
||||
(not (eq? '_...superclass-args...
|
||||
(arg-id (cadr args))))))])
|
||||
(cons
|
||||
(list*
|
||||
(if (eq? mode 'new)
|
||||
(flow-spacer/n 3)
|
||||
flow-spacer)
|
||||
(if (arg-starts-optional? (car args))
|
||||
(to-flow (make-element #f (list spacer "[")))
|
||||
flow-spacer)
|
||||
(let ([a ((arg->elem #f) (car args))]
|
||||
[next (if dots-next?
|
||||
(make-element
|
||||
#f (list spacer
|
||||
((arg->elem #f)
|
||||
(cadr args))))
|
||||
"")])
|
||||
(to-flow
|
||||
(cond
|
||||
[(null? ((if dots-next? cddr cdr) args))
|
||||
(make-element
|
||||
#f
|
||||
(list a next (racketparenfont ")")))]
|
||||
[(equal? next "") a]
|
||||
[else
|
||||
(make-element #f (list a next))])))
|
||||
(if (and (null? ((if dots-next? cddr cdr) args))
|
||||
(not result-next-line?))
|
||||
end
|
||||
not-end))
|
||||
(loop ((if dots-next? cddr cdr)
|
||||
args)))))))))))))))
|
||||
(if result-next-line?
|
||||
(list (list (make-flow (make-table-if-necessary "prototype"
|
||||
(list end)))))
|
||||
|
|
@ -489,11 +504,11 @@
|
|||
(content-thunk))))
|
||||
|
||||
(define-syntax-rule (defparam id arg contract desc ...)
|
||||
(defproc* ([(id) contract] [(id [arg contract]) void?]) desc ...))
|
||||
(defproc* #:kind "parameter" ([(id) contract] [(id [arg contract]) void?]) desc ...))
|
||||
(define-syntax-rule (defparam* id arg in-contract out-contract desc ...)
|
||||
(defproc* ([(id) out-contract] [(id [arg in-contract]) void?]) desc ...))
|
||||
(defproc* #:kind "parameter" ([(id) out-contract] [(id [arg in-contract]) void?]) desc ...))
|
||||
(define-syntax-rule (defboolparam id arg desc ...)
|
||||
(defproc* ([(id) boolean?] [(id [arg any/c]) void?]) desc ...))
|
||||
(defproc* #:kind "parameter" ([(id) boolean?] [(id [arg any/c]) void?]) desc ...))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -585,229 +600,231 @@
|
|||
(make-table
|
||||
boxed-style
|
||||
(cons
|
||||
(list (make-flow
|
||||
(list
|
||||
(let* ([the-name
|
||||
(let ([just-name
|
||||
(make-target-element*
|
||||
make-toc-target-element
|
||||
(if (pair? name)
|
||||
(car (syntax-e stx-id))
|
||||
stx-id)
|
||||
(annote-exporting-library
|
||||
(to-element
|
||||
(if (pair? name)
|
||||
(make-just-context (car name)
|
||||
(car (syntax-e stx-id)))
|
||||
stx-id)))
|
||||
(let ([name (if (pair? name) (car name) name)])
|
||||
(list* (list 'info name)
|
||||
(list 'type 'struct: name)
|
||||
(list 'predicate name '?)
|
||||
(append
|
||||
(if cname-id
|
||||
(list (list 'constructor (syntax-e cname-id)))
|
||||
null)
|
||||
(map (lambda (f)
|
||||
(list 'accessor name '-
|
||||
(field-name f)))
|
||||
fields)
|
||||
(filter-map
|
||||
(lambda (f)
|
||||
(if (or (not immutable?)
|
||||
(and (pair? (car f))
|
||||
(memq '#:mutable
|
||||
(car f))))
|
||||
(list 'mutator 'set- name '-
|
||||
(field-name f) '!)
|
||||
#f))
|
||||
fields)))))])
|
||||
(if (pair? name)
|
||||
(make-element
|
||||
#f
|
||||
(list just-name
|
||||
(hspace 1)
|
||||
(to-element
|
||||
(make-just-context
|
||||
(cadr name)
|
||||
(cadr (syntax-e stx-id))))))
|
||||
just-name))]
|
||||
[sym-length (lambda (s)
|
||||
(string-length (symbol->string s)))]
|
||||
[short-width
|
||||
(apply + (length fields) 8
|
||||
(append
|
||||
(map sym-length
|
||||
(append (if (pair? name) name (list name))
|
||||
(map field-name fields)))
|
||||
(map (lambda (f)
|
||||
(if (pair? (car f))
|
||||
(+ 3 2 (string-length (keyword->string
|
||||
(cadar f))))
|
||||
0))
|
||||
fields)))])
|
||||
(if (and (short-width . < . max-proto-width)
|
||||
immutable?
|
||||
(not transparent?)
|
||||
(not cname-id))
|
||||
(make-omitable-paragraph
|
||||
(list
|
||||
(to-element
|
||||
`(,(racket struct)
|
||||
,the-name
|
||||
,(map field-view 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)))]
|
||||
[split-field-line?
|
||||
(max-proto-width . < . (+ 8
|
||||
(if (pair? name)
|
||||
(+ (sym-length (car name))
|
||||
1
|
||||
(sym-length (cadr name)))
|
||||
(sym-length name))
|
||||
1
|
||||
(if (pair? fields)
|
||||
(sym-length (field-name (car fields)))
|
||||
0)
|
||||
1))])
|
||||
(make-table
|
||||
(if one-right-column?
|
||||
(list
|
||||
((add-background-label "struct")
|
||||
(make-flow
|
||||
(list
|
||||
(let* ([the-name
|
||||
(let ([just-name
|
||||
(make-target-element*
|
||||
make-toc-target-element
|
||||
(if (pair? name)
|
||||
(car (syntax-e stx-id))
|
||||
stx-id)
|
||||
(annote-exporting-library
|
||||
(to-element
|
||||
(if (pair? name)
|
||||
(make-just-context (car name)
|
||||
(car (syntax-e stx-id)))
|
||||
stx-id)))
|
||||
(let ([name (if (pair? name) (car name) name)])
|
||||
(list* (list 'info name)
|
||||
(list 'type 'struct: name)
|
||||
(list 'predicate name '?)
|
||||
(append
|
||||
(if cname-id
|
||||
(list (list 'constructor (syntax-e cname-id)))
|
||||
null)
|
||||
(map (lambda (f)
|
||||
(list 'accessor name '-
|
||||
(field-name f)))
|
||||
fields)
|
||||
(filter-map
|
||||
(lambda (f)
|
||||
(if (or (not immutable?)
|
||||
(and (pair? (car f))
|
||||
(memq '#:mutable
|
||||
(car f))))
|
||||
(list 'mutator 'set- name '-
|
||||
(field-name f) '!)
|
||||
#f))
|
||||
fields)))))])
|
||||
(if (pair? name)
|
||||
(make-element
|
||||
#f
|
||||
;; Shift all extra width to last column:
|
||||
(make-style #f (list
|
||||
(make-table-columns
|
||||
(for/list ([i 5])
|
||||
(if (i . < . 4)
|
||||
(make-style #f (list (column-attributes '((width . "0*")))))
|
||||
(make-style #f null)))))))
|
||||
(list just-name
|
||||
(hspace 1)
|
||||
(to-element
|
||||
(make-just-context
|
||||
(cadr name)
|
||||
(cadr (syntax-e stx-id))))))
|
||||
just-name))]
|
||||
[sym-length (lambda (s)
|
||||
(string-length (symbol->string s)))]
|
||||
[short-width
|
||||
(apply + (length fields) 8
|
||||
(append
|
||||
(map sym-length
|
||||
(append (if (pair? name) name (list name))
|
||||
(map field-name fields)))
|
||||
(map (lambda (f)
|
||||
(if (pair? (car f))
|
||||
(+ 3 2 (string-length (keyword->string
|
||||
(cadar f))))
|
||||
0))
|
||||
fields)))])
|
||||
(if (and (short-width . < . max-proto-width)
|
||||
immutable?
|
||||
(not transparent?)
|
||||
(not cname-id))
|
||||
(make-omitable-paragraph
|
||||
(list
|
||||
(to-element
|
||||
`(,(racket struct)
|
||||
,the-name
|
||||
,(map field-view 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)))]
|
||||
[split-field-line?
|
||||
(max-proto-width . < . (+ 8
|
||||
(if (pair? name)
|
||||
(+ (sym-length (car name))
|
||||
1
|
||||
(sym-length (cadr name)))
|
||||
(sym-length name))
|
||||
1
|
||||
(if (pair? fields)
|
||||
(sym-length (field-name (car fields)))
|
||||
0)
|
||||
1))])
|
||||
(make-table
|
||||
(if one-right-column?
|
||||
#f
|
||||
;; Shift all extra width to last column:
|
||||
(make-style #f (list
|
||||
(make-table-columns
|
||||
(for/list ([i 5])
|
||||
(if (i . < . 4)
|
||||
(make-style #f (list (column-attributes '((width . "0*")))))
|
||||
(make-style #f null)))))))
|
||||
(append
|
||||
(list
|
||||
(append
|
||||
(list
|
||||
(append
|
||||
(list (to-flow (make-element #f
|
||||
(list
|
||||
(racketparenfont "(")
|
||||
(racket 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 (racketparenfont ")"))
|
||||
null)))))
|
||||
(if split-field-line?
|
||||
(list (to-flow (make-element 'no-break the-name))
|
||||
'cont
|
||||
'cont)
|
||||
(list (to-flow (make-element 'no-break the-name))
|
||||
(to-flow (make-element
|
||||
#f (list spacer (racketparenfont "("))))
|
||||
(to-flow (make-element 'no-break
|
||||
(let ([f (to-element (field-view (car fields)))])
|
||||
(if (null? (cdr fields))
|
||||
(list f (racketparenfont ")"))
|
||||
f)))))))))
|
||||
(if split-field-line?
|
||||
(list
|
||||
(list flow-spacer flow-spacer flow-spacer
|
||||
(to-flow (make-element
|
||||
#f (list spacer (racketparenfont "("))))
|
||||
(to-flow (make-element 'no-break
|
||||
(let ([f (to-element (field-view (car fields)))])
|
||||
(if (null? (cdr fields))
|
||||
(list f (racketparenfont ")"))
|
||||
f))))))
|
||||
null)
|
||||
(if (short-width . < . max-proto-width)
|
||||
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 (racketparenfont
|
||||
(if (and immutable?
|
||||
(not transparent?)
|
||||
(not cname-id))
|
||||
"))"
|
||||
")"))))
|
||||
e)))))
|
||||
(loop (cdr fields))))))
|
||||
(if cname-id
|
||||
(let ([kw (to-element (if extra-cname?
|
||||
'#:extra-constructor-name
|
||||
'#:constructor-name))]
|
||||
[nm (to-element cname-id)]
|
||||
[close? (and immutable?
|
||||
(not transparent?))])
|
||||
(if (max-proto-width . < . (+ 8 ; "(struct "
|
||||
1 ; space between kw & name
|
||||
(element-width kw)
|
||||
(element-width nm)
|
||||
(if close? 1 0)))
|
||||
;; use two lines
|
||||
(list (a-right-column (to-flow kw))
|
||||
(a-right-column
|
||||
(list (to-flow (make-element #f
|
||||
(list
|
||||
(racketparenfont "(")
|
||||
(racket 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 (racketparenfont ")"))
|
||||
null)))))
|
||||
(if split-field-line?
|
||||
(list (to-flow (make-element 'no-break the-name))
|
||||
'cont
|
||||
'cont)
|
||||
(list (to-flow (make-element 'no-break the-name))
|
||||
(to-flow (make-element
|
||||
#f (list spacer (racketparenfont "("))))
|
||||
(to-flow (make-element 'no-break
|
||||
(let ([f (to-element (field-view (car fields)))])
|
||||
(if (null? (cdr fields))
|
||||
(list f (racketparenfont ")"))
|
||||
f)))))))))
|
||||
(if split-field-line?
|
||||
(list
|
||||
(list flow-spacer flow-spacer flow-spacer
|
||||
(to-flow (make-element
|
||||
#f (list spacer (racketparenfont "("))))
|
||||
(to-flow (make-element 'no-break
|
||||
(let ([f (to-element (field-view (car fields)))])
|
||||
(if (null? (cdr fields))
|
||||
(list f (racketparenfont ")"))
|
||||
f))))))
|
||||
null)
|
||||
(if (short-width . < . max-proto-width)
|
||||
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
|
||||
(if close?
|
||||
(make-element #f (list nm (racketparenfont ")")))
|
||||
nm))))
|
||||
;; use one line
|
||||
(list (a-right-column
|
||||
(to-flow (make-element
|
||||
(let ([e (to-element (field-view fld))])
|
||||
(if (null? (cdr fields))
|
||||
(make-element
|
||||
#f
|
||||
(list e (racketparenfont
|
||||
(if (and immutable?
|
||||
(not transparent?)
|
||||
(not cname-id))
|
||||
"))"
|
||||
")"))))
|
||||
e)))))
|
||||
(loop (cdr fields))))))
|
||||
(if cname-id
|
||||
(let ([kw (to-element (if extra-cname?
|
||||
'#:extra-constructor-name
|
||||
'#:constructor-name))]
|
||||
[nm (to-element cname-id)]
|
||||
[close? (and immutable?
|
||||
(not transparent?))])
|
||||
(if (max-proto-width . < . (+ 8 ; "(struct "
|
||||
1 ; space between kw & name
|
||||
(element-width kw)
|
||||
(element-width nm)
|
||||
(if close? 1 0)))
|
||||
;; use two lines
|
||||
(list (a-right-column (to-flow kw))
|
||||
(a-right-column
|
||||
(to-flow
|
||||
(if close?
|
||||
(make-element #f (list nm (racketparenfont ")")))
|
||||
nm))))
|
||||
;; use one line
|
||||
(list (a-right-column
|
||||
(to-flow (make-element
|
||||
#f
|
||||
(append
|
||||
(list kw
|
||||
(hspace 1)
|
||||
nm)
|
||||
(if close?
|
||||
(list (racketparenfont ")"))
|
||||
null))))))))
|
||||
null)
|
||||
(cond
|
||||
[(and (not immutable?) transparent?)
|
||||
(list
|
||||
(a-right-column (to-flow (to-element '#:mutable)))
|
||||
(a-right-column (to-flow (make-element
|
||||
#f
|
||||
(append
|
||||
(list kw
|
||||
(hspace 1)
|
||||
nm)
|
||||
(if close?
|
||||
(list (racketparenfont ")"))
|
||||
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))
|
||||
(racketparenfont ")"))))))]
|
||||
[(not immutable?)
|
||||
(list
|
||||
(a-right-column (to-flow (make-element
|
||||
#f
|
||||
(list (to-element '#:mutable)
|
||||
(racketparenfont ")"))))))]
|
||||
[transparent?
|
||||
(list
|
||||
(a-right-column (to-flow (make-element
|
||||
#f
|
||||
(list (if prefab?
|
||||
(to-element '#:prefab)
|
||||
(to-element '#:transparent))
|
||||
(racketparenfont ")"))))))]
|
||||
[else null])))))))))
|
||||
(list (if prefab?
|
||||
(to-element '#:prefab)
|
||||
(to-element '#:transparent))
|
||||
(racketparenfont ")"))))))]
|
||||
[(not immutable?)
|
||||
(list
|
||||
(a-right-column (to-flow (make-element
|
||||
#f
|
||||
(list (to-element '#:mutable)
|
||||
(racketparenfont ")"))))))]
|
||||
[transparent?
|
||||
(list
|
||||
(a-right-column (to-flow (make-element
|
||||
#f
|
||||
(list (if prefab?
|
||||
(to-element '#:prefab)
|
||||
(to-element '#:transparent))
|
||||
(racketparenfont ")"))))))]
|
||||
[else null]))))))))))
|
||||
(map (lambda (v field-contract)
|
||||
(cond
|
||||
[(pair? v)
|
||||
|
|
@ -832,23 +849,33 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-syntax-rule (defthing id result desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defthing (list (quote-syntax/loc id)) (list 'id) #f
|
||||
(list (racketblock0 result))
|
||||
(lambda () (list desc ...)))))
|
||||
(define-syntax defthing
|
||||
(syntax-rules ()
|
||||
[(_ #:kind kind id result desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defthing kind
|
||||
(list (quote-syntax/loc id)) (list 'id) #f
|
||||
(list (racketblock0 result))
|
||||
(lambda () (list desc ...))))]
|
||||
[(_ id result desc ...)
|
||||
(defthing #:kind #f id result desc ...)]))
|
||||
|
||||
(define-syntax-rule (defthing* ([id result] ...) desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f
|
||||
(list (racketblock0 result) ...)
|
||||
(lambda () (list desc ...)))))
|
||||
(define-syntax defthing*
|
||||
(syntax-rules ()
|
||||
[(_ #:kind kind ([id result] ...) desc ...)
|
||||
(with-togetherable-racket-variables
|
||||
()
|
||||
()
|
||||
(*defthing kind
|
||||
(list (quote-syntax/loc id) ...) (list 'id ...) #f
|
||||
(list (racketblock0 result) ...)
|
||||
(lambda () (list desc ...))))]
|
||||
[(_ ([id result] ...) desc ...)
|
||||
(defthing* #:kind #f ([id result] ...) desc ...)]))
|
||||
|
||||
(define (*defthing stx-ids names form? result-contracts content-thunk
|
||||
(define (*defthing kind stx-ids names form? result-contracts content-thunk
|
||||
[result-values (map (lambda (x) #f) result-contracts)])
|
||||
(make-box-splice
|
||||
(cons
|
||||
|
|
@ -857,9 +884,13 @@
|
|||
(list
|
||||
(make-table
|
||||
boxed-style
|
||||
(map
|
||||
(lambda (stx-id name result-contract result-value)
|
||||
(list
|
||||
(for/list ([stx-id (in-list stx-ids)]
|
||||
[name (in-list names)]
|
||||
[result-contract (in-list result-contracts)]
|
||||
[result-value (in-list result-values)]
|
||||
[i (in-naturals)])
|
||||
(list
|
||||
((if (zero? i) (add-background-label (or kind "value")) values)
|
||||
(make-flow
|
||||
(make-table-if-necessary
|
||||
"argcontract"
|
||||
|
|
@ -930,12 +961,11 @@
|
|||
(to-flow (make-element #f (list spacer "=" spacer)))
|
||||
(make-flow (list result-block)))))
|
||||
'cont))
|
||||
null)))))))
|
||||
stx-ids names result-contracts result-values))))
|
||||
null)))))))))))
|
||||
(content-thunk))))
|
||||
|
||||
(define (defthing/proc id contract descs)
|
||||
(*defthing (list id) (list (syntax-e id)) #f (list contract)
|
||||
(define (defthing/proc kind id contract descs)
|
||||
(*defthing kind (list id) (list (syntax-e id)) #f (list contract)
|
||||
(lambda () descs)))
|
||||
|
||||
(define (make-target-element* inner-make-target-element stx-id content wrappers)
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@
|
|||
|
||||
(define (*defsignature stx-id supers body-thunk indent?)
|
||||
(*defthing
|
||||
"signature"
|
||||
(list stx-id)
|
||||
(list (syntax-e stx-id))
|
||||
#t
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
"../scheme.rkt"
|
||||
"../struct.rkt"
|
||||
(only-in "../core.rkt"
|
||||
make-style style-name
|
||||
nested-flow? nested-flow-blocks nested-flow-style)
|
||||
make-style style-name style-properties
|
||||
nested-flow? nested-flow-blocks nested-flow-style
|
||||
make-nested-flow)
|
||||
"../html-properties.rkt"
|
||||
racket/contract/base
|
||||
(for-syntax scheme/base
|
||||
|
|
@ -21,7 +22,8 @@
|
|||
with-racket-variables
|
||||
with-togetherable-racket-variables
|
||||
vertical-inset-style
|
||||
boxed-style)
|
||||
boxed-style
|
||||
add-background-label)
|
||||
|
||||
(define vertical-inset-style
|
||||
(make-style 'vertical-inset null))
|
||||
|
|
@ -29,6 +31,44 @@
|
|||
(define boxed-style
|
||||
(make-style 'boxed (list (make-attributes (list (cons 'class "RBoxed"))))))
|
||||
|
||||
(define ((add-background-label what) l)
|
||||
(list
|
||||
(make-nested-flow
|
||||
(make-style "RBackgroundLabel" (list 'decorative 'command (alt-tag "div")
|
||||
(make-attributes '((class . "SIEHidden")))))
|
||||
(list
|
||||
(make-nested-flow
|
||||
(make-style "RBackgroundLabelInner" (list (alt-tag "div")))
|
||||
(list (make-omitable-paragraph what)))))
|
||||
(let* ([a (car l)]
|
||||
[remake (if (paragraph? a)
|
||||
(lambda (sa)
|
||||
(paragraph
|
||||
(sa (paragraph-style a))
|
||||
(paragraph-content a)))
|
||||
(lambda (sa)
|
||||
(table
|
||||
(sa (table-style a))
|
||||
(table-blockss a))))])
|
||||
(remake
|
||||
(lambda (s)
|
||||
(make-style (style-name s)
|
||||
(let ([p (style-properties s)])
|
||||
(if (ormap attributes? p)
|
||||
(for/list ([i (in-list p)])
|
||||
(if (attributes? i)
|
||||
(let ([al (attributes-assoc i)])
|
||||
(if (assq 'class al)
|
||||
(for/list ([a (in-list al)])
|
||||
(if (eq? (car a) 'class)
|
||||
(cons 'class (string-append (cdr a) " RForeground"))
|
||||
a))
|
||||
(attributes (cons '(class . "RForeground")
|
||||
al))))
|
||||
i))
|
||||
(cons (attributes '((class . "RForeground")))
|
||||
p)))))))))
|
||||
|
||||
(begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes))
|
||||
|
||||
(define-syntax (with-togetherable-racket-variables stx)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,11 @@
|
|||
font-family: serif;
|
||||
}
|
||||
|
||||
/* Sans-serif: */
|
||||
.RBackgroundLabelInner {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Inherited methods, left margin */
|
||||
|
||||
|
|
@ -199,3 +204,30 @@
|
|||
.Rfilecontent {
|
||||
margin: 0em 0em 0em 0em;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* For background labels */
|
||||
|
||||
.RBackgroundLabel {
|
||||
float: right;
|
||||
width: 0px;
|
||||
}
|
||||
|
||||
.RBackgroundLabelInner {
|
||||
position: relative;
|
||||
width: 25em;
|
||||
left: -25.5em;
|
||||
top: 0px;
|
||||
text-align: right;
|
||||
color: white;
|
||||
z-index: 0;
|
||||
font-weight: bold;
|
||||
text-transform: uppercase;
|
||||
}
|
||||
|
||||
.RForeground {
|
||||
position: relative;
|
||||
left: 0px;
|
||||
top: 0px;
|
||||
z-index: 1;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -64,3 +64,6 @@
|
|||
\newcommand{\Rfilename}[1]{#1}
|
||||
\newenvironment{Rfilecontent}{}{}
|
||||
\newcommand{\RfilecontentBox}[1]{#1}
|
||||
|
||||
\newcommand{\RBackgroundLabel}[1]{}
|
||||
\newenvironment{RBackgroundLabelInner}{}{}
|
||||
|
|
|
|||
|
|
@ -145,12 +145,13 @@
|
|||
|
||||
(define/override (render-nested-flow i part ri starting-item?)
|
||||
(define s (nested-flow-style i))
|
||||
(if (and s (or (eq? (style-name s) 'inset)
|
||||
(eq? (style-name s) 'code-inset)))
|
||||
(begin (printf " ")
|
||||
(parameterize ([current-indent (make-indent 2)])
|
||||
(super render-nested-flow i part ri starting-item?)))
|
||||
(super render-nested-flow i part ri starting-item?)))
|
||||
(unless (memq 'decorative (style-properties s))
|
||||
(if (and s (or (eq? (style-name s) 'inset)
|
||||
(eq? (style-name s) 'code-inset)))
|
||||
(begin (printf " ")
|
||||
(parameterize ([current-indent (make-indent 2)])
|
||||
(super render-nested-flow i part ri starting-item?)))
|
||||
(super render-nested-flow i part ri starting-item?))))
|
||||
|
||||
(define/override (render-other i part ht)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -607,6 +607,9 @@ The following @tech{style properties} are currently recognized:
|
|||
rendering form for @tech{boxing contexts} (such as a table cell); see
|
||||
@racket[box-mode].}
|
||||
|
||||
@item{@racket['decorative] --- The content of the nested flow is intended
|
||||
for decoration. Text output skips a decorative nested flow.}
|
||||
|
||||
]}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -671,7 +671,7 @@ sub-sections.}
|
|||
@; ------------------------------------------------------------------------
|
||||
@section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values}
|
||||
|
||||
@defform/subs[(defproc prototype
|
||||
@defform/subs[(defproc maybe-kind prototype
|
||||
result-contract-expr-datum
|
||||
pre-flow ...)
|
||||
([prototype (id arg-spec ...)
|
||||
|
|
@ -682,6 +682,8 @@ sub-sections.}
|
|||
(keyword arg-id contract-expr-datum default-expr)
|
||||
ellipses
|
||||
ellipses+]
|
||||
[maybe-kind code:blank
|
||||
(code:line #:kind kind-string-expr)]
|
||||
[ellipses @#,lit-ellipses]
|
||||
[ellipses+ @#,lit-ellipses+])]{
|
||||
|
||||
|
|
@ -739,10 +741,18 @@ The typesetting of all information before the @racket[pre-flow]s
|
|||
ignores the source layout, except that the local formatting is
|
||||
preserved for contracts and default-values expressions. The information
|
||||
is formatted to fit (if possible) in the number of characters specified
|
||||
by the @racket[current-display-width] parameter.}
|
||||
by the @racket[current-display-width] parameter.
|
||||
|
||||
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, although the current documentation
|
||||
style converts the string to all uppercase.}
|
||||
|
||||
|
||||
@defform[(defproc* ([prototype
|
||||
@defform[(defproc* maybe-kind
|
||||
([prototype
|
||||
result-contract-expr-datum] ...)
|
||||
pre-flow ...)]{
|
||||
|
||||
|
|
@ -756,9 +766,12 @@ can also be defined by a single @racket[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 maybe-contracts
|
||||
@defform/subs[(defform maybe-kind maybe-id maybe-literals form-datum
|
||||
maybe-contracts
|
||||
pre-flow ...)
|
||||
([maybe-id code:blank
|
||||
([maybe-kind code:blank
|
||||
(code:line #:kind kind-string-expr)]
|
||||
[maybe-id code:blank
|
||||
(code:line #:id id)
|
||||
(code:line #:id [id id-expr])]
|
||||
[maybe-literals code:blank
|
||||
|
|
@ -774,6 +787,10 @@ result of @racket[id-expr]) whose syntax is described by
|
|||
@racket[id], then @racket[form-datum] must have the form @racket[(id
|
||||
. _datum)].
|
||||
|
||||
If @racket[#:kind kind-string-expr] is supplied, it is used in the
|
||||
same way as for @racket[defproc], but the default kind is
|
||||
@racket["syntax"].
|
||||
|
||||
If @racket[#:id [id id-expr]] is supplied, then @racket[id] is the
|
||||
identifier as it appears in the @racket[form-datum] (to be replaced by
|
||||
a defining instance), and @racket[id-expr] produces the identifier to
|
||||
|
|
@ -808,13 +825,14 @@ The typesetting of @racket[form-datum], @racket[subform-datum], and
|
|||
@racket[contract-expr-datum] preserves the source layout, like
|
||||
@racket[racketblock].}
|
||||
|
||||
@defform[(defform* maybe-id maybe-literals [form-datum ...+] maybe-contracts
|
||||
@defform[(defform* maybe-kind maybe-id maybe-literals [form-datum ...+]
|
||||
maybe-contracts
|
||||
pre-flow ...)]{
|
||||
|
||||
Like @racket[defform], but for multiple forms using the same
|
||||
@racket[_id].}
|
||||
|
||||
@defform[(defform/subs maybe-id maybe-literals form-datum
|
||||
@defform[(defform/subs maybe-kind maybe-id maybe-literals form-datum
|
||||
([nonterm-id clause-datum ...+] ...)
|
||||
maybe-contracts
|
||||
pre-flow ...)]{
|
||||
|
|
@ -826,20 +844,20 @@ non-terminals shown with the @racket[_id] form. Each
|
|||
@racket[clause-datum] is preserved.}
|
||||
|
||||
|
||||
@defform[(defform*/subs maybe-id maybe-literals [form-datum ...]
|
||||
@defform[(defform*/subs maybe-kind maybe-id maybe-literals [form-datum ...]
|
||||
maybe-contracts
|
||||
pre-flow ...)]{
|
||||
|
||||
Like @racket[defform/subs], but for multiple forms for @racket[_id].}
|
||||
|
||||
|
||||
@defform[(defform/none maybe-literal form-datum maybe-contracts
|
||||
@defform[(defform/none maybe-kind maybe-literal form-datum maybe-contracts
|
||||
pre-flow ...)]{
|
||||
|
||||
Like @racket[defform], but without registering a definition.}
|
||||
|
||||
|
||||
@defform[(defidform id pre-flow ...)]{
|
||||
@defform[(defidform maybe-kind id pre-flow ...)]{
|
||||
|
||||
Like @racket[defform], but with a plain @racket[id] as the form.}
|
||||
|
||||
|
|
@ -917,9 +935,14 @@ Like @racket[defparam], but the contract on a parameter argument is
|
|||
@racket[boolean?].}
|
||||
|
||||
|
||||
@defform[(defthing id contract-expr-datum pre-flow ...)]{
|
||||
@defform[(defthing maybe-kind id contract-expr-datum pre-flow ...)]{
|
||||
|
||||
Like @racket[defproc], but for a non-procedure binding.
|
||||
|
||||
If @racket[#:kind kind-string-expr] is supplied as
|
||||
@racket[maybe-kind], it is used in the same way as for
|
||||
@racket[defproc], but the default kind is @racket["value"].}
|
||||
|
||||
Like @racket[defproc], but for a non-procedure binding.}
|
||||
|
||||
@deftogether[(
|
||||
@defform[ (defstruct* struct-name ([field-name contract-expr-datum] ...)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user