suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

scribble: adjust `def...' box to show a background label in HTML

Browse Source 
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 2012-06-17 08:32:13 +08:00
parent f1aa676101
commit 4fc0b01398
11 changed files with 640 additions and 420 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/scribble/html-render.rkt
View File

@ -141,8 +141,13 @@
(style-properties style)))]) (style-properties style)))])
(let ([name (style-name style)]) (let ([name (style-name style)])
(if (string? name) (if (string? name)
(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] (cons `[class ,name]
a) a))
a)))) a))))
;; combine a 'class attribute from both cl and al ;; combine a 'class attribute from both cl and al
@ -681,7 +686,8 @@
css-addition-path) css-addition-path)
(list style-file) (list style-file)
style-extra-files)) 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) (body ([id ,(or (extract-part-body-id d ri)
"scribble-racket-lang-org")]) "scribble-racket-lang-org")])
,@(render-toc-view d ri) ,@(render-toc-view d ri)
@ -1316,7 +1322,8 @@
(extract-table-cell-styles t)))))) (extract-table-cell-styles t))))))
(define/override (render-nested-flow t part ri starting-item?) (define/override (render-nested-flow t part ri starting-item?)
`((blockquote [,@(combine-class `((,(or (style->tag (nested-flow-style t)) 'blockquote)
[,@(combine-class
(cond (cond
[(eq? 'code-inset (style-name (nested-flow-style t))) [(eq? 'code-inset (style-name (nested-flow-style t)))
`([class "SCodeFlow"])] `([class "SCodeFlow"])]

9
collects/scribble/private/manual-class.rkt
View File

@ -14,6 +14,7 @@
"manual-bind.rkt" "manual-bind.rkt"
"manual-method.rkt" "manual-method.rkt"
"manual-proc.rkt" "manual-proc.rkt"
"manual-vars.rkt"
scheme/list scheme/list
(for-syntax scheme/base) (for-syntax scheme/base)
(for-label scheme/base (for-label scheme/base
@ -187,10 +188,12 @@
(define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc) (define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc)
(make-table (make-table
'boxed boxed-style
(append (append
(list (list
(list (make-flow (list
((add-background-label (symbol->string kind))
(make-flow
(list (list
(make-omitable-paragraph (make-omitable-paragraph
(list (let ([target-maker (id-to-target-maker stx-id #t)] (list (let ([target-maker (id-to-target-maker stx-id #t)]
@ -219,7 +222,7 @@
(case kind (case kind
[(class) (racket class?)] [(class) (racket class?)]
[(interface) (racket interface?)] [(interface) (racket interface?)]
[(mixin) (racketblockelem (class? . -> . class?))]))))))) [(mixin) (racketblockelem (class? . -> . class?))]))))))))
(if super (if super
(list (list
(list (make-flow (list (make-flow

109
collects/scribble/private/manual-form.rkt
View File

@ -26,7 +26,7 @@
(define-syntax (defform*/subs stx) (define-syntax (defform*/subs stx)
(syntax-case 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 ...] ...) ([non-term-id non-term-form ...] ...)
#:contracts ([contract-nonterm contract-expr] ...) #:contracts ([contract-nonterm contract-expr] ...)
desc ...) desc ...)
@ -57,7 +57,7 @@
(lit ...) (lit ...)
([form [defined-id spec]] [form [defined-id spec1]] ... ([form [defined-id spec]] [form [defined-id spec1]] ...
[non-term (non-term-id non-term-form ...)] ...) [non-term (non-term-id non-term-form ...)] ...)
(*defforms defined-id-expr (*defforms kind defined-id-expr
'(spec spec1 ...) '(spec spec1 ...)
(list (lambda (x) (racketblock0/form new-spec)) (list (lambda (x) (racketblock0/form new-spec))
(lambda (ignored) (racketblock0/form spec1)) ...) (lambda (ignored) (racketblock0/form spec1)) ...)
@ -70,6 +70,15 @@
(lambda () (racketblock0 contract-expr))) (lambda () (racketblock0 contract-expr)))
...) ...)
(lambda () (list desc ...))))))] (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 ...] [(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...) ([non-term-id non-term-form ...] ...)
desc ...) desc ...)
@ -78,74 +87,130 @@
([non-term-id non-term-form ...] ...) ([non-term-id non-term-form ...] ...)
#:contracts () #:contracts ()
desc ...))] 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 ...) desc ...)
(syntax/loc stx (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 ...] ...) ([non-term-id non-term-form ...] ...)
#:contracts () #:contracts ()
desc ...))] 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 ...] [(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
([non-term-id non-term-form ...] ...) ([non-term-id non-term-form ...] ...)
desc ...) desc ...)
(with-syntax ([(_ _ _ [spec . _] . _) stx]) (with-syntax ([(_ _ _ [spec . _] . _) stx])
(syntax/loc 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 ...] ...) ([non-term-id non-term-form ...] ...)
desc ...)))] 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 ...) [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
(syntax/loc stx (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 ...))])) desc ...))]))
(define-syntax (defform* stx) (define-syntax (defform* stx)
(syntax-case 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 ...) [(_ #:id id #:literals lits [spec ...] desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id #:literals lits [spec ...] () desc ...))] (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 ...) [(_ #:literals lits [spec ...] desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:literals lits [spec ...] () desc ...))] (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 ...) [(_ #:id id [spec ...] desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id [spec ...] () desc ...))] (defform*/subs #:id id [spec ...] () desc ...))]
[(_ #:kind kind [spec ...] desc ...)
(syntax/loc stx
(defform*/subs #:kind kind [spec ...] () desc ...))]
[(_ [spec ...] desc ...) [(_ [spec ...] desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs [spec ...] () desc ...))])) (defform*/subs [spec ...] () desc ...))]))
(define-syntax (defform stx) (define-syntax (defform stx)
(syntax-case 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 ...) [(_ #:id id #:literals (lit ...) spec desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))] (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 ...) [(_ #:id id spec desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id #:literals () [spec] () desc ...))] (defform*/subs #:id id #:literals () [spec] () desc ...))]
[(_ #:literals (lit ...) spec desc ...) [(_ #:literals (lit ...) spec desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:literals (lit ...) [spec] () desc ...))] (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 ...) [(_ spec desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs [spec] () desc ...))])) (defform*/subs [spec] () desc ...))]))
(define-syntax (defform/subs stx) (define-syntax (defform/subs stx)
(syntax-case 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 ...) [(_ #:id id #:literals lits spec subs desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id #:literals lits [spec] subs desc ...))] (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 ...) [(_ #:id id spec subs desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:id id #:literals () [spec] subs desc ...))] (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 ...) [(_ #:literals lits spec subs desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs #:literals lits [spec] subs desc ...))] (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 ...) [(_ spec subs desc ...)
(syntax/loc stx (syntax/loc stx
(defform*/subs [spec] subs desc ...))])) (defform*/subs [spec] subs desc ...))]))
(define-syntax (defform/none stx) (define-syntax (defform/none stx)
(syntax-case 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 (begin
(for-each (lambda (id) (for-each (lambda (id)
(unless (identifier? id) (unless (identifier? id)
@ -157,16 +222,25 @@
#'(with-togetherable-racket-variables #'(with-togetherable-racket-variables
(lit ...) (lit ...)
([form/none spec]) ([form/none spec])
(*defforms #f (*defforms kind #f
'(spec) (list (lambda (ignored) (racketblock0/form spec))) '(spec) (list (lambda (ignored) (racketblock0/form spec)))
null null null null
(list (list (lambda () (racket contract-id)) (list (list (lambda () (racket contract-id))
(lambda () (racketblock0 contract-expr))) (lambda () (racketblock0 contract-expr)))
...) ...)
(lambda () (list desc ...)))))] (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 ...) [(fm #:literals (lit ...) spec desc ...)
(syntax/loc stx (syntax/loc stx
(fm #:literals (lit ...) spec #:contracts () desc ...))] (fm #:literals (lit ...) spec #:contracts () desc ...))]
[(fm #:kind kind spec desc ...)
(syntax/loc stx
(fm #:kind kind #:literals () spec desc ...))]
[(fm spec desc ...) [(fm spec desc ...)
(syntax/loc stx (syntax/loc stx
(fm #:literals () spec desc ...))])) (fm #:literals () spec desc ...))]))
@ -181,17 +255,20 @@
(define-syntax (defidform stx) (define-syntax (defidform stx)
(syntax-case stx () (syntax-case stx ()
[(_ spec-id desc ...) [(_ #:kind kind spec-id desc ...)
#'(with-togetherable-racket-variables #'(with-togetherable-racket-variables
() ()
() ()
(*defforms (quote-syntax/loc spec-id) (*defforms kind (quote-syntax/loc spec-id)
'(spec-id) '(spec-id)
(list (lambda (x) (make-omitable-paragraph (list x)))) (list (lambda (x) (make-omitable-paragraph (list x))))
null null
null 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) (define (into-blockquote s)
(make-blockquote "leftindent" (make-blockquote "leftindent"
@ -336,7 +413,7 @@
tag))) tag)))
(car content)))) (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 '(... ...+)]) (parameterize ([current-meta-list '(... ...+)])
(make-box-splice (make-box-splice
(cons (cons
@ -346,10 +423,11 @@
(make-table (make-table
boxed-style boxed-style
(append (append
(map (for/list ([form (in-list forms)]
(lambda (form form-proc) [form-proc (in-list form-procs)]
[i (in-naturals)])
(list (list
(make-flow ((if (zero? i) (add-background-label (or kind "syntax")) values)
(list (list
((or form-proc ((or form-proc
(lambda (x) (lambda (x)
@ -358,7 +436,6 @@
(and kw-id (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(defform-site kw-id))))))) (defform-site kw-id)))))))
forms form-procs)
(if (null? sub-procs) (if (null? sub-procs)
null null
(list (list flow-empty-line) (list (list flow-empty-line)

84
collects/scribble/private/manual-proc.rkt
View File

@ -113,29 +113,38 @@
"expected a result contract, found a string" #'c) "expected a result contract, found a string" #'c)
#'(racketblock0 c))])) #'(racketblock0 c))]))
(define-syntax-rule (defproc (id arg ...) result desc ...) (define-syntax defproc
(defproc* [[(id arg ...) result]] desc ...)) (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* (define-syntax defproc*
(syntax-rules () (syntax-rules ()
[(_ [[proto result] ...] desc ...) [(_ #:kind kind #:mode m #:within cl [[proto result] ...] desc ...)
(defproc* #:mode procedure #:within #f [[proto result] ...] desc ...)]
[(_ #:mode m #:within cl [[proto result] ...] desc ...)
(with-togetherable-racket-variables (with-togetherable-racket-variables
() ()
([proc proto] ...) ([proc proto] ...)
(*defproc 'm (quote-syntax/loc cl) (*defproc kind
'm (quote-syntax/loc cl)
(list (extract-proc-id proto) ...) (list (extract-proc-id proto) ...)
'[proto ...] '[proto ...]
(list (arg-contracts proto) ...) (list (arg-contracts proto) ...)
(list (arg-defaults proto) ...) (list (arg-defaults proto) ...)
(list (lambda () (result-contract result)) ...) (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 (define-struct arg
(special? kw id optional? starts-optional? ends-optional? num-closers)) (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 stx-ids prototypes arg-contractss arg-valss result-contracts
content-thunk) content-thunk)
(define max-proto-width (current-display-width)) (define max-proto-width (current-display-width))
@ -336,9 +345,15 @@
. >= . (- max-proto-width 7))) . >= . (- max-proto-width 7)))
(define end (list flow-spacer (to-flow 'rarr) (define end (list flow-spacer (to-flow 'rarr)
flow-spacer (make-flow (list res)))) flow-spacer (make-flow (list res))))
(define (get-label)
(case mode
[(new make) "constructor"]
[(send) "method"]
[else (or kind "procedure")]))
(append (append
(list (list
(list (list
((if first? (add-background-label (get-label)) values)
(make-flow (make-flow
(if short? (if short?
;; The single-line case: ;; The single-line case:
@ -420,7 +435,7 @@
end end
not-end)) not-end))
(loop ((if dots-next? cddr cdr) (loop ((if dots-next? cddr cdr)
args)))))))))))))) args)))))))))))))))
(if result-next-line? (if result-next-line?
(list (list (make-flow (make-table-if-necessary "prototype" (list (list (make-flow (make-table-if-necessary "prototype"
(list end))))) (list end)))))
@ -489,11 +504,11 @@
(content-thunk)))) (content-thunk))))
(define-syntax-rule (defparam id arg contract desc ...) (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 ...) (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 ...) (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,7 +600,9 @@
(make-table (make-table
boxed-style boxed-style
(cons (cons
(list (make-flow (list
((add-background-label "struct")
(make-flow
(list (list
(let* ([the-name (let* ([the-name
(let ([just-name (let ([just-name
@ -807,7 +824,7 @@
(to-element '#:prefab) (to-element '#:prefab)
(to-element '#:transparent)) (to-element '#:transparent))
(racketparenfont ")"))))))] (racketparenfont ")"))))))]
[else null]))))))))) [else null]))))))))))
(map (lambda (v field-contract) (map (lambda (v field-contract)
(cond (cond
[(pair? v) [(pair? v)
@ -832,23 +849,33 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-syntax-rule (defthing id result desc ...) (define-syntax defthing
(syntax-rules ()
[(_ #:kind kind id result desc ...)
(with-togetherable-racket-variables (with-togetherable-racket-variables
() ()
() ()
(*defthing (list (quote-syntax/loc id)) (list 'id) #f (*defthing kind
(list (quote-syntax/loc id)) (list 'id) #f
(list (racketblock0 result)) (list (racketblock0 result))
(lambda () (list desc ...))))) (lambda () (list desc ...))))]
[(_ id result desc ...)
(defthing #:kind #f id result desc ...)]))
(define-syntax-rule (defthing* ([id result] ...) desc ...) (define-syntax defthing*
(syntax-rules ()
[(_ #:kind kind ([id result] ...) desc ...)
(with-togetherable-racket-variables (with-togetherable-racket-variables
() ()
() ()
(*defthing (list (quote-syntax/loc id) ...) (list 'id ...) #f (*defthing kind
(list (quote-syntax/loc id) ...) (list 'id ...) #f
(list (racketblock0 result) ...) (list (racketblock0 result) ...)
(lambda () (list desc ...))))) (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)]) [result-values (map (lambda (x) #f) result-contracts)])
(make-box-splice (make-box-splice
(cons (cons
@ -857,9 +884,13 @@
(list (list
(make-table (make-table
boxed-style boxed-style
(map (for/list ([stx-id (in-list stx-ids)]
(lambda (stx-id name result-contract result-value) [name (in-list names)]
[result-contract (in-list result-contracts)]
[result-value (in-list result-values)]
[i (in-naturals)])
(list (list
((if (zero? i) (add-background-label (or kind "value")) values)
(make-flow (make-flow
(make-table-if-necessary (make-table-if-necessary
"argcontract" "argcontract"
@ -930,12 +961,11 @@
(to-flow (make-element #f (list spacer "=" spacer))) (to-flow (make-element #f (list spacer "=" spacer)))
(make-flow (list result-block))))) (make-flow (list result-block)))))
'cont)) 'cont))
null))))))) null)))))))))))
stx-ids names result-contracts result-values))))
(content-thunk)))) (content-thunk))))
(define (defthing/proc id contract descs) (define (defthing/proc kind id contract descs)
(*defthing (list id) (list (syntax-e id)) #f (list contract) (*defthing kind (list id) (list (syntax-e id)) #f (list contract)
(lambda () descs))) (lambda () descs)))
(define (make-target-element* inner-make-target-element stx-id content wrappers) (define (make-target-element* inner-make-target-element stx-id content wrappers)

1
collects/scribble/private/manual-unit.rkt
View File

@ -40,6 +40,7 @@
(define (*defsignature stx-id supers body-thunk indent?) (define (*defsignature stx-id supers body-thunk indent?)
(*defthing (*defthing
"signature"
(list stx-id) (list stx-id)
(list (syntax-e stx-id)) (list (syntax-e stx-id))
#t #t

46
collects/scribble/private/manual-vars.rkt
View File

@ -3,8 +3,9 @@
"../scheme.rkt" "../scheme.rkt"
"../struct.rkt" "../struct.rkt"
(only-in "../core.rkt" (only-in "../core.rkt"
make-style style-name make-style style-name style-properties
nested-flow? nested-flow-blocks nested-flow-style) nested-flow? nested-flow-blocks nested-flow-style
make-nested-flow)
"../html-properties.rkt" "../html-properties.rkt"
racket/contract/base racket/contract/base
(for-syntax scheme/base (for-syntax scheme/base
@ -21,7 +22,8 @@
with-racket-variables with-racket-variables
with-togetherable-racket-variables with-togetherable-racket-variables
vertical-inset-style vertical-inset-style
boxed-style) boxed-style
add-background-label)
(define vertical-inset-style (define vertical-inset-style
(make-style 'vertical-inset null)) (make-style 'vertical-inset null))
@ -29,6 +31,44 @@
(define boxed-style (define boxed-style
(make-style 'boxed (list (make-attributes (list (cons 'class "RBoxed")))))) (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)) (begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes))
(define-syntax (with-togetherable-racket-variables stx) (define-syntax (with-togetherable-racket-variables stx)

32
collects/scribble/racket.css
View File

@ -14,6 +14,11 @@
font-family: serif; font-family: serif;
} }
/* Sans-serif: */
.RBackgroundLabelInner {
font-family: sans-serif;
}
/* ---------------------------------------- */ /* ---------------------------------------- */
/* Inherited methods, left margin */ /* Inherited methods, left margin */
@ -199,3 +204,30 @@
.Rfilecontent { .Rfilecontent {
margin: 0em 0em 0em 0em; 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;
}

3
collects/scribble/racket.tex
View File

@ -64,3 +64,6 @@
\newcommand{\Rfilename}[1]{#1} \newcommand{\Rfilename}[1]{#1}
\newenvironment{Rfilecontent}{}{} \newenvironment{Rfilecontent}{}{}
\newcommand{\RfilecontentBox}[1]{#1} \newcommand{\RfilecontentBox}[1]{#1}
\newcommand{\RBackgroundLabel}[1]{}
\newenvironment{RBackgroundLabelInner}{}{}

3
collects/scribble/text-render.rkt
View File

@ -145,12 +145,13 @@
(define/override (render-nested-flow i part ri starting-item?) (define/override (render-nested-flow i part ri starting-item?)
(define s (nested-flow-style i)) (define s (nested-flow-style i))
(unless (memq 'decorative (style-properties s))
(if (and s (or (eq? (style-name s) 'inset) (if (and s (or (eq? (style-name s) 'inset)
(eq? (style-name s) 'code-inset))) (eq? (style-name s) 'code-inset)))
(begin (printf " ") (begin (printf " ")
(parameterize ([current-indent (make-indent 2)]) (parameterize ([current-indent (make-indent 2)])
(super render-nested-flow i part ri starting-item?))) (super render-nested-flow i part ri starting-item?)))
(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) (define/override (render-other i part ht)
(cond (cond

3
collects/scribblings/scribble/core.scrbl
View File

@ -607,6 +607,9 @@ The following @tech{style properties} are currently recognized:
rendering form for @tech{boxing contexts} (such as a table cell); see rendering form for @tech{boxing contexts} (such as a table cell); see
@racket[box-mode].} @racket[box-mode].}
@item{@racket['decorative] --- The content of the nested flow is intended
for decoration. Text output skips a decorative nested flow.}
]} ]}

47
collects/scribblings/scribble/manual.scrbl
View File

@ -671,7 +671,7 @@ sub-sections.}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values} @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 result-contract-expr-datum
pre-flow ...) pre-flow ...)
([prototype (id arg-spec ...) ([prototype (id arg-spec ...)
@ -682,6 +682,8 @@ sub-sections.}
(keyword arg-id contract-expr-datum default-expr) (keyword arg-id contract-expr-datum default-expr)
ellipses ellipses
ellipses+] ellipses+]
[maybe-kind code:blank
(code:line #:kind kind-string-expr)]
[ellipses @#,lit-ellipses] [ellipses @#,lit-ellipses]
[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 ignores the source layout, except that the local formatting is
preserved for contracts and default-values expressions. The information preserved for contracts and default-values expressions. The information
is formatted to fit (if possible) in the number of characters specified 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] ...) result-contract-expr-datum] ...)
pre-flow ...)]{ 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.} 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 ...) 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)
(code:line #:id [id id-expr])] (code:line #:id [id id-expr])]
[maybe-literals code:blank [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 @racket[id], then @racket[form-datum] must have the form @racket[(id
. _datum)]. . _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 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 identifier as it appears in the @racket[form-datum] (to be replaced by
a defining instance), and @racket[id-expr] produces the identifier to 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[contract-expr-datum] preserves the source layout, like
@racket[racketblock].} @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 ...)]{ pre-flow ...)]{
Like @racket[defform], but for multiple forms using the same Like @racket[defform], but for multiple forms using the same
@racket[_id].} @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 ...+] ...) ([nonterm-id clause-datum ...+] ...)
maybe-contracts maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
@ -826,20 +844,20 @@ non-terminals shown with the @racket[_id] form. Each
@racket[clause-datum] is preserved.} @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 maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
Like @racket[defform/subs], but for multiple forms for @racket[_id].} 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 ...)]{ pre-flow ...)]{
Like @racket[defform], but without registering a definition.} 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.} 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?].} @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[( @deftogether[(
@defform[ (defstruct* struct-name ([field-name contract-expr-datum] ...) @defform[ (defstruct* struct-name ([field-name contract-expr-datum] ...)