From 4fc0b01398f39f91ed3d657783a82e0a783c18f1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 17 Jun 2012 08:32:13 +0800 Subject: [PATCH] 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 --- collects/scribble/html-render.rkt | 39 +- collects/scribble/private/manual-class.rkt | 61 +- collects/scribble/private/manual-form.rkt | 127 +++- collects/scribble/private/manual-proc.rkt | 688 +++++++++++---------- collects/scribble/private/manual-unit.rkt | 1 + collects/scribble/private/manual-vars.rkt | 46 +- collects/scribble/racket.css | 32 + collects/scribble/racket.tex | 3 + collects/scribble/text-render.rkt | 13 +- collects/scribblings/scribble/core.scrbl | 3 + collects/scribblings/scribble/manual.scrbl | 47 +- 11 files changed, 640 insertions(+), 420 deletions(-) diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index 0dc3dad9..a8f099e6 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -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]>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)]) diff --git a/collects/scribble/private/manual-class.rkt b/collects/scribble/private/manual-class.rkt index 8f97596e..b2edd921 100644 --- a/collects/scribble/private/manual-class.rkt +++ b/collects/scribble/private/manual-class.rkt @@ -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 diff --git a/collects/scribble/private/manual-form.rkt b/collects/scribble/private/manual-form.rkt index 20f40bac..e793daed 100644 --- a/collects/scribble/private/manual-form.rkt +++ b/collects/scribble/private/manual-form.rkt @@ -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) diff --git a/collects/scribble/private/manual-proc.rkt b/collects/scribble/private/manual-proc.rkt index 3665333d..fe910929 100644 --- a/collects/scribble/private/manual-proc.rkt +++ b/collects/scribble/private/manual-proc.rkt @@ -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) diff --git a/collects/scribble/private/manual-unit.rkt b/collects/scribble/private/manual-unit.rkt index a336e62e..0f1e4a48 100644 --- a/collects/scribble/private/manual-unit.rkt +++ b/collects/scribble/private/manual-unit.rkt @@ -40,6 +40,7 @@ (define (*defsignature stx-id supers body-thunk indent?) (*defthing + "signature" (list stx-id) (list (syntax-e stx-id)) #t diff --git a/collects/scribble/private/manual-vars.rkt b/collects/scribble/private/manual-vars.rkt index 6cfb7b7f..6c1d733b 100644 --- a/collects/scribble/private/manual-vars.rkt +++ b/collects/scribble/private/manual-vars.rkt @@ -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) diff --git a/collects/scribble/racket.css b/collects/scribble/racket.css index 3bb29352..350deffe 100644 --- a/collects/scribble/racket.css +++ b/collects/scribble/racket.css @@ -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; +} diff --git a/collects/scribble/racket.tex b/collects/scribble/racket.tex index 438ee499..b9f5990b 100644 --- a/collects/scribble/racket.tex +++ b/collects/scribble/racket.tex @@ -64,3 +64,6 @@ \newcommand{\Rfilename}[1]{#1} \newenvironment{Rfilecontent}{}{} \newcommand{\RfilecontentBox}[1]{#1} + +\newcommand{\RBackgroundLabel}[1]{} +\newenvironment{RBackgroundLabelInner}{}{} diff --git a/collects/scribble/text-render.rkt b/collects/scribble/text-render.rkt index 025b0843..c5baffd0 100644 --- a/collects/scribble/text-render.rkt +++ b/collects/scribble/text-render.rkt @@ -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 diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index 4430724a..c8047202 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -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.} + ]} diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 36933db3..345ac3c4 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -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] ...)