suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

scribble: add style to distinguish definition sites

Browse Source 
original commit: e4a0bff456d2c40d688c6b49322ed94ec666b69c
This commit is contained in:
Matthew Flatt 2013-11-14 07:40:10 -07:00
parent d96d31582f
commit cc37b26e35
15 changed files with 259 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/core.scrbl
View File

@ -894,6 +894,12 @@ Like @racket[target-element], the content is also a kind of section
label to be shown in the ``on this page'' table for HTML output.} label to be shown in the ``on this page'' table for HTML output.}
@defstruct[(toc-target2-element toc-target-element) ([toc-content content?])]{
Extends @racket[target-element] with a separate field for the content
to be shown in the ``on this page'' table for HTML output.}
@defstruct[(page-target-element target-element) ()]{ @defstruct[(page-target-element target-element) ()]{
Like @racket[target-element], but a link to the element goes to the Like @racket[target-element], but a link to the element goes to the

6
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/scheme.scrbl
View File

@ -102,11 +102,13 @@ it is added to the end on its own line.}
@defproc[(to-element [v any/c] @defproc[(to-element [v any/c]
[#:expr? expr? any/c #f] [#:expr? expr? any/c #f]
[#:escapes? escapes? any/c #t]) element?]{ [#:escapes? escapes? any/c #t]
[#:defn? defn? any/c #f]) element?]{
Like @racket[to-paragraph], except that source-location information is Like @racket[to-paragraph], except that source-location information is
mostly ignored, since the result is meant to be inlined into a mostly ignored, since the result is meant to be inlined into a
paragraph.} paragraph. If @racket[defn?] is true, then an identifier is styled as
a definition site.}
@defproc[(to-element/no-color [v any/c] @defproc[(to-element/no-color [v any/c]
[#:expr? expr? any/c #f] [#:expr? expr? any/c #f]

7
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/struct.scrbl
View File

@ -1,11 +1,11 @@
#lang scribble/manual #lang scribble/manual
@(require (except-in "utils.rkt" @(require (except-in "utils.rkt"
make-part make-paragraph make-table make-itemization make-compound-paragraph make-part make-paragraph make-table make-itemization make-compound-paragraph
make-element make-toc-element make-target-element make-toc-target-element make-element make-toc-element make-target-element make-toc-target-element make-toc-target2-element
make-page-target-element make-redirect-target-element make-link-element make-page-target-element make-redirect-target-element make-link-element
make-index-element make-index-element
make-target-url target-url struct:target-url target-url? target-url-addr make-target-url target-url struct:target-url target-url? target-url-addr
toc-element-toc-content part-title-content paragraph-content toc-element-toc-content toc-target2-element-toc-content part-title-content paragraph-content
element? element-content element-style) element? element-content element-style)
(for-label scribble/manual-struct (for-label scribble/manual-struct
scribble/struct scribble/struct
@ -38,7 +38,7 @@ The following structure types are re-exported, but the constructors and some sel
are replaced as documented further below: are replaced as documented further below:
@racketblock[part paragraph table itemization compound-paragraph @racketblock[part paragraph table itemization compound-paragraph
element toc-element target-element toc-target-element element toc-element target-element toc-target-element toc-target2-element
page-target-element redirect-target-element link-element page-target-element redirect-target-element link-element
index-element] index-element]
@ -201,6 +201,7 @@ formats to the current one.}
@defproc[(make-toc-element [style any/c] [content list?] [toc-content list?]) toc-element?] @defproc[(make-toc-element [style any/c] [content list?] [toc-content list?]) toc-element?]
@defproc[(make-target-element [style any/c] [content list?] [tag tag?]) target-element?] @defproc[(make-target-element [style any/c] [content list?] [tag tag?]) target-element?]
@defproc[(make-toc-target-element [style any/c] [content list?] [tag tag?]) toc-target-element?] @defproc[(make-toc-target-element [style any/c] [content list?] [tag tag?]) toc-target-element?]
@defproc[(make-toc-target2-element [style any/c] [content list?] [tag tag?] [toc-content content?]) toc-target2-element?]
@defproc[(make-page-target-element [style any/c] [content list?] [tag tag?]) page-target-element?] @defproc[(make-page-target-element [style any/c] [content list?] [tag tag?]) page-target-element?]
@defproc[(make-redirect-target-element [style any/c] [content list?] [tag tag?] @defproc[(make-redirect-target-element [style any/c] [content list?] [tag tag?]
[alt-path path-string?] [alt-anchor string?]) redirect-target-element?] [alt-path path-string?] [alt-anchor string?]) redirect-target-element?]

11
pkgs/scribble-pkgs/scribble-lib/scribble/base-render.rkt
View File

@ -645,7 +645,11 @@
(when (multiarg-element? i) (when (multiarg-element? i)
(collect-content (multiarg-element-contents i) ci)) (collect-content (multiarg-element-contents i) ci))
(when (list? i) (when (list? i)
(for ([e (in-list i)]) (collect-content e ci)))))) (for ([e (in-list i)]) (collect-content e ci)))
(when (toc-element? i)
(collect-content (toc-element-toc-content i) ci))
(when (toc-target2-element? i)
(collect-content (toc-target2-element-toc-content i) ci)))))
(define/public (collect-target-element i ci) (define/public (collect-target-element i ci)
(let ([t (generate-tag (target-element-tag i) ci)]) (let ([t (generate-tag (target-element-tag i) ci)])
@ -741,7 +745,10 @@
(hash-set! (resolve-info-delays ri) e v))))] (hash-set! (resolve-info-delays ri) e v))))]
[(link-element? i) [(link-element? i)
(resolve-get d ri (link-element-tag i))]) (resolve-get d ri (link-element-tag i))])
(resolve-content (element-content i) d ri)] (resolve-content (element-content i) d ri)
(cond
[(toc-target2-element? i) (resolve-content (toc-target2-element-toc-content i) d ri)]
[(toc-element? i) (resolve-content (toc-element-toc-content i) d ri)])]
[(multiarg-element? i) [(multiarg-element? i)
(resolve-content (multiarg-element-contents i) d ri)])) (resolve-content (multiarg-element-contents i) d ri)]))

1
pkgs/scribble-pkgs/scribble-lib/scribble/core.rkt
View File

@ -180,6 +180,7 @@
[(toc-element element) ([toc-content content?])] [(toc-element element) ([toc-content content?])]
[(target-element element) ([tag tag?])] [(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()] [(toc-target-element target-element) ()]
[(toc-target2-element toc-target-element) ([toc-content content?])]
[(page-target-element target-element) ()] [(page-target-element target-element) ()]
[(redirect-target-element target-element) ([alt-path path-string?] [(redirect-target-element target-element) ([alt-path path-string?]
[alt-anchor string?])] [alt-anchor string?])]

4
pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
View File

@ -722,7 +722,9 @@
(if (part? p) (if (part? p)
(or (part-title-content p) (or (part-title-content p)
"???") "???")
(element-content p)) (if (toc-target2-element? p)
(toc-target2-element-toc-content p)
(element-content p)))
d ri))))))))) d ri)))))))))
ps))))))) ps)))))))

26
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-bind.rkt
View File

@ -36,7 +36,7 @@
(define-syntax-rule (sigelem sig elem) (define-syntax-rule (sigelem sig elem)
(*sig-elem (quote-syntax sig) 'elem)) (*sig-elem (quote-syntax sig) 'elem))
(define (*sig-elem sig elem) (define (*sig-elem sig elem #:defn? [defn? #f])
(let ([s (to-element/no-color elem)]) (let ([s (to-element/no-color elem)])
(make-delayed-element (make-delayed-element
(lambda (renderer sec ri) (lambda (renderer sec ri)
@ -48,8 +48,8 @@
(make-element (make-element
symbol-color symbol-color
(list (list
(cond [sd (make-link-element syntax-link-color (list s) stag)] (cond [sd (make-link-element (if defn? syntax-def-color syntax-link-color) (list s) stag)]
[vtag (make-link-element value-link-color (list s) vtag)] [vtag (make-link-element (if defn? value-def-color value-link-color) (list s) vtag)]
[else s]))))) [else s])))))
(lambda () s) (lambda () s)
(lambda () s)))) (lambda () s))))
@ -90,10 +90,12 @@
(define (definition-site name stx-id form?) (define (definition-site name stx-id form?)
(let ([sig (current-signature)]) (let ([sig (current-signature)])
(if sig (define (gen defn?)
(*sig-elem (sig-id sig) name) (if sig
(annote-exporting-library (*sig-elem #:defn? defn? (sig-id sig) name)
(to-element (make-just-context name stx-id)))))) (annote-exporting-library
(to-element #:defn? defn? (make-just-context name stx-id)))))
(values (gen #t) (gen #f))))
(define checkers (make-hash)) (define checkers (make-hash))
@ -177,10 +179,12 @@
(let ([dep? #t]) (let ([dep? #t])
(let ([maker (if form? (let ([maker (if form?
(id-to-form-target-maker id dep?) (id-to-form-target-maker id dep?)
(id-to-target-maker id dep?))] (id-to-target-maker id dep?))])
[elem (if show-libs? (define-values (elem elem-ref)
(definition-site (syntax-e id) id form?) (if show-libs?
(to-element id))]) (definition-site (syntax-e id) id form?)
(values (to-element id #:defn? #t)
(to-element id))))
(if maker (if maker
(maker elem (maker elem
(lambda (tag) (lambda (tag)

13
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-class.rkt
View File

@ -195,27 +195,30 @@
(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)]
[content (list (annote-exporting-library [content (annote-exporting-library
(to-element stx-id)))]) (to-element #:defn? #t stx-id))]
[ref-content (annote-exporting-library
(to-element stx-id))])
(if target-maker (if target-maker
(target-maker (target-maker
content content
(lambda (tag) (lambda (tag)
((if whole-page? ((if whole-page?
make-page-target-element make-page-target-element
make-toc-target-element) (lambda (s c t)
(make-toc-target2-element s c t ref-content)))
#f #f
(list (list
(make-index-element (make-index-element
#f content tag #f content tag
(list (datum-intern-literal (list (datum-intern-literal
(symbol->string (syntax-e stx-id)))) (symbol->string (syntax-e stx-id))))
content (list ref-content)
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-index-desc (syntax-e stx-id) libs))))) (make-index-desc (syntax-e stx-id) libs)))))
tag))) tag)))
(car content))) content))
spacer ":" spacer spacer ":" spacer
(case kind (case kind
[(class) (racket class?)] [(class) (racket class?)]

67
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-form.rkt
View File

@ -87,26 +87,26 @@
[defined-id-expr (if (syntax-e #'d.defined-id-expr) [defined-id-expr (if (syntax-e #'d.defined-id-expr)
#'d.defined-id-expr #'d.defined-id-expr
#'(quote-syntax defined-id))] #'(quote-syntax defined-id))]
[new-spec [(new-spec ...)
(let loop ([spec #'spec]) (for/list ([spec (in-list (syntax->list #'(spec spec1 ...)))])
(if (and (identifier? spec) (let loop ([spec spec])
(free-identifier=? spec #'defined-id)) (if (and (identifier? spec)
(datum->syntax #'here '(unsyntax x) spec spec) (free-identifier=? spec #'defined-id))
(syntax-case spec () (datum->syntax #'here '(unsyntax x) spec spec)
[(a . b) (syntax-case spec ()
(datum->syntax spec [(a . b)
(cons (loop #'a) (loop #'b)) (datum->syntax spec
spec (cons (loop #'a) (loop #'b))
spec)] spec
[_ spec])))]) spec)]
#'(with-togetherable-racket-variables [_ spec]))))])
#'(with-togetherable-racket-variables
(l.lit ...) (l.lit ...)
([form [defined-id spec]] [form [defined-id spec1]] ... ([form [defined-id spec]] [form [defined-id spec1]] ...
[non-term (g.non-term-id g.non-term-form ...)] ...) [non-term (g.non-term-id g.non-term-form ...)] ...)
(*defforms k.kind lt.expr defined-id-expr (*defforms k.kind lt.expr 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)) ...)
'((g.non-term-id g.non-term-form ...) ...) '((g.non-term-id g.non-term-form ...) ...)
(list (list (lambda () (racket g.non-term-id)) (list (list (lambda () (racket g.non-term-id))
(lambda () (racketblock0/form g.non-term-form)) (lambda () (racketblock0/form g.non-term-form))
@ -298,27 +298,27 @@
(define (meta-symbol? s) (memq s '(... ...+ ?))) (define (meta-symbol? s) (memq s '(... ...+ ?)))
(define (defform-site kw-id) (define (defform-site kw-id)
(let ([target-maker (id-to-form-target-maker kw-id #t)] (let ([target-maker (id-to-form-target-maker kw-id #t)])
[content (list (definition-site (syntax-e kw-id) (define-values (content ref-content) (definition-site (syntax-e kw-id) kw-id #t))
kw-id #t))])
(if target-maker (if target-maker
(target-maker (target-maker
content content
(lambda (tag) (lambda (tag)
(make-toc-target-element (make-toc-target2-element
#f #f
(if kw-id (if kw-id
(list (make-index-element (make-index-element
#f content tag #f content tag
(list (datum-intern-literal (symbol->string (syntax-e kw-id)))) (list (datum-intern-literal (symbol->string (syntax-e kw-id))))
content (list ref-content)
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-form-index-desc (syntax-e kw-id) (make-form-index-desc (syntax-e kw-id)
libs))))) libs))))
content) content)
tag))) tag
(car content)))) ref-content)))
content)))
(define (*defforms kind link? kw-id forms form-procs subs sub-procs contract-procs content-thunk) (define (*defforms kind link? kw-id forms form-procs subs sub-procs contract-procs content-thunk)
(parameterize ([current-meta-list '(... ...+)]) (parameterize ([current-meta-list '(... ...+)])
@ -341,10 +341,11 @@
(make-omitable-paragraph (make-omitable-paragraph
(list (to-element `(,x . ,(cdr form))))))) (list (to-element `(,x . ,(cdr form)))))))
(and kw-id (and kw-id
(eq? form (car forms)) (if (eq? form (car forms))
(if link? (if link?
(defform-site kw-id) (defform-site kw-id)
(to-element kw-id)))))))) (to-element #:defn? #t kw-id))
(to-element #:defn? #t kw-id))))))))
(if (null? sub-procs) (if (null? sub-procs)
null null
(list (list flow-empty-line) (list (list flow-empty-line)

13
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-method.rkt
View File

@ -20,14 +20,19 @@
(define-syntax-rule (xmethod class/intf-id method-id) (define-syntax-rule (xmethod class/intf-id method-id)
(elem (method class/intf-id method-id) " in " (racket class/intf-id))) (elem (method class/intf-id method-id) " in " (racket class/intf-id)))
(define (*method sym id) (define (*method sym id
(**method sym id)) #:defn? [defn? #f])
(**method sym id #:defn? defn?))
(define (**method sym id/tag) (define (**method sym id/tag
#:defn? [defn? #f])
(define content (list (symbol->string sym))) (define content (list (symbol->string sym)))
(define (mk tag) (define (mk tag)
(make-element symbol-color (make-element symbol-color
(list (make-link-element value-link-color content (list (make-link-element (if defn?
value-def-color
value-link-color)
content
(method-tag tag sym))))) (method-tag tag sym)))))
(if (identifier? id/tag) (if (identifier? id/tag)
(make-delayed-element (make-delayed-element

195
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-proc.rkt
View File

@ -332,54 +332,57 @@
(if (and first? link?) (if (and first? link?)
(let* ([mname (extract-id prototype stx-id)] (let* ([mname (extract-id prototype stx-id)]
[target-maker (id-to-target-maker within-id #f)] [target-maker (id-to-target-maker within-id #f)]
[content (list (*method mname within-id))]) [content (*method mname within-id #:defn? #t)]
[ref-content (*method mname within-id)])
(if target-maker (if target-maker
(target-maker (target-maker
content content
(lambda (ctag) (lambda (ctag)
(let ([tag (method-tag ctag mname)]) (let ([tag (method-tag ctag mname)])
(make-toc-target-element (make-toc-target2-element
#f #f
(list (make-index-element (list (make-index-element
#f #f
content content
tag tag
(list (datum-intern-literal (symbol->string mname))) (list (datum-intern-literal (symbol->string mname)))
content (list ref-content)
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-method-index-desc (make-method-index-desc
(syntax-e within-id) (syntax-e within-id)
libs mname ctag))))) libs mname ctag)))))
tag)))) tag
(car content))) ref-content))))
(*method (extract-id prototype stx-id) within-id))))] content))
(*method (extract-id prototype stx-id) within-id #:defn? #t))))]
[(and first? link?) [(and first? link?)
(define the-id (extract-id prototype stx-id)) (define the-id (extract-id prototype stx-id))
(let ([target-maker (id-to-target-maker stx-id #t)] (let ([target-maker (id-to-target-maker stx-id #t)])
[content (list (definition-site the-id stx-id #f))]) (define-values (content ref-content) (definition-site the-id stx-id #f))
(if target-maker (if target-maker
(target-maker (target-maker
content content
(lambda (tag) (lambda (tag)
(make-toc-target-element (make-toc-target2-element
#f #f
(list (make-index-element (make-index-element
#f content tag #f content tag
(list (datum-intern-literal (symbol->string the-id))) (list (datum-intern-literal (symbol->string the-id)))
content (list ref-content)
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-procedure-index-desc the-id libs))))) (make-procedure-index-desc the-id libs))))
tag))) tag
(car content)))] ref-content)))
content))]
[else [else
(define the-id (extract-id prototype stx-id)) (define the-id (extract-id prototype stx-id))
((if link? annote-exporting-library values) ((if link? annote-exporting-library values)
(let ([sig (current-signature)]) (let ([sig (current-signature)])
(if sig (if sig
(*sig-elem (sig-id sig) the-id) (*sig-elem #:defn? #t (sig-id sig) the-id)
(to-element (make-just-context the-id stx-id)))))])) (to-element #:defn? #t (make-just-context the-id stx-id)))))]))
(define p-depth (prototype-depth prototype)) (define p-depth (prototype-depth prototype))
(define flat-size (+ (prototype-size args + + #f) (define flat-size (+ (prototype-size args + + #f)
p-depth p-depth
@ -698,45 +701,47 @@
(list (list
(let* ([the-name (let* ([the-name
(let ([just-name (let ([just-name
(if link? (let ([name-id (if (pair? name)
(make-target-element* (make-just-context (car name)
make-toc-target-element (car (syntax-e stx-id)))
(if (pair? name) stx-id)])
(car (syntax-e stx-id)) (if link?
stx-id) (let ()
(annote-exporting-library (define (gen defn?)
(to-element (annote-exporting-library
(if (pair? name) (to-element #:defn? defn? name-id)))
(make-just-context (car name) (define content (gen #t))
(car (syntax-e stx-id))) (define ref-content (gen #f))
stx-id))) (make-target-element*
(let ([name (if (pair? name) (car name) name)]) (lambda (s c t)
(list* (list 'info name) (make-toc-target2-element s c t ref-content))
(list 'type 'struct: name) (if (pair? name)
(list 'predicate name '?) (car (syntax-e stx-id))
(append stx-id)
(if cname-id content
(list (list 'constructor (syntax-e cname-id))) (let ([name (if (pair? name) (car name) name)])
null) (list* (list 'info name)
(map (lambda (f) (list 'type 'struct: name)
(list 'accessor name '- (list 'predicate name '?)
(field-name f))) (append
fields) (if cname-id
(filter-map (list (list 'constructor (syntax-e cname-id)))
(lambda (f) null)
(if (or (not immutable?) (map (lambda (f)
(and (pair? (car f)) (list 'accessor name '-
(memq '#:mutable (field-name f)))
(car f)))) fields)
(list 'mutator 'set- name '- (filter-map
(field-name f) '!) (lambda (f)
#f)) (if (or (not immutable?)
fields))))) (and (pair? (car f))
(to-element (memq '#:mutable
(if (pair? name) (car f))))
(make-just-context (car name) (list 'mutator 'set- name '-
(car (syntax-e stx-id))) (field-name f) '!)
stx-id)))]) #f))
fields))))))
(to-element #:defn? #t name-id)))])
(if (pair? name) (if (pair? name)
(make-element (make-element
#f #f
@ -1024,27 +1029,30 @@
(let ([target-maker (let ([target-maker
(and link? (and link?
((if form? id-to-form-target-maker id-to-target-maker) ((if form? id-to-form-target-maker id-to-target-maker)
stx-id #t))] stx-id #t))])
[content (list (if link? (define-values (content ref-content)
(definition-site name stx-id form?) (if link?
(to-element (make-just-context name stx-id))))]) (definition-site name stx-id form?)
(let ([s (make-just-context name stx-id)])
(values (to-element #:defn? #t s)
(to-element s)))))
(if target-maker (if target-maker
(target-maker (target-maker
content content
(lambda (tag) (lambda (tag)
(make-toc-target-element (make-toc-target2-element
#f #f
(list (make-index-element
(make-index-element #f
#f content
content tag
tag (list (datum-intern-literal (symbol->string name)))
(list (datum-intern-literal (symbol->string name))) (list ref-content)
content (with-exporting-libraries
(with-exporting-libraries (lambda (libs) (make-thing-index-desc name libs))))
(lambda (libs) (make-thing-index-desc name libs))))) tag
tag))) ref-content)))
(car content))))))) content))))))
(make-flow (make-flow
(list (list
(make-omitable-paragraph (make-omitable-paragraph
@ -1087,24 +1095,23 @@
#t)]) #t)])
(if target-maker (if target-maker
(target-maker (target-maker
(list content) content
(lambda (tag) (lambda (tag)
(inner-make-target-element (inner-make-target-element
#f #f
(list (make-index-element
(make-index-element #f
#f content
(list content) tag
tag (list name)
(list name) (list (racketidfont (make-element value-link-color
(list (racketidfont (make-element value-link-color (list name))))
(list name)))) (with-exporting-libraries
(with-exporting-libraries (lambda (libs)
(lambda (libs) (let ([name (string->symbol name)])
(let ([name (string->symbol name)]) (if (eq? 'info (caar wrappers))
(if (eq? 'info (caar wrappers)) (make-struct-index-desc name libs)
(make-struct-index-desc name libs) (make-procedure-index-desc name libs))))))
(make-procedure-index-desc name libs)))))))
tag))) tag)))
content)) content))
(cdr wrappers)))) (cdr wrappers))))

9
pkgs/scribble-pkgs/scribble-lib/scribble/racket.css
View File

@ -91,11 +91,17 @@
color: #262680; color: #262680;
} }
.RktSymDef { /* used with RktSym at def site */
}
.RktValLink { .RktValLink {
text-decoration: none; text-decoration: none;
color: blue; color: blue;
} }
.RktValDef { /* used with RktValLink at def site */
}
.RktModLink { .RktModLink {
text-decoration: none; text-decoration: none;
color: blue; color: blue;
@ -107,6 +113,9 @@
/* font-weight: bold; */ /* font-weight: bold; */
} }
.RktStxDef { /* used with RktStxLink at def site */
}
.RktRes { .RktRes {
color: #0000af; color: #0000af;
} }

71
pkgs/scribble-pkgs/scribble-lib/scribble/racket.rkt
View File

@ -4,6 +4,7 @@
"search.rkt" "search.rkt"
"private/manual-sprop.rkt" "private/manual-sprop.rkt"
"private/on-demand.rkt" "private/on-demand.rkt"
"html-properties.rkt"
file/convertible file/convertible
racket/extflonum racket/extflonum
(for-syntax racket/base)) (for-syntax racket/base))
@ -36,6 +37,8 @@
error-color error-color
syntax-link-color syntax-link-color
value-link-color value-link-color
syntax-def-color
value-def-color
module-color module-color
module-link-color module-link-color
block-color block-color
@ -52,10 +55,15 @@
make-element-id-transformer make-element-id-transformer
element-id-transformer?)) element-id-transformer?))
(define (make-racket-style s #:tt? [tt? #t]) (define (make-racket-style s
#:tt? [tt? #t]
#:extras [extras null])
(make-style s (if tt? (make-style s (if tt?
(cons 'tt-chars scheme-properties) (cons 'tt-chars
scheme-properties))) (append extras
scheme-properties))
(append extras
scheme-properties))))
(define-on-demand output-color (make-racket-style "RktOut")) (define-on-demand output-color (make-racket-style "RktOut"))
(define-on-demand input-color (make-racket-style "RktIn")) (define-on-demand input-color (make-racket-style "RktIn"))
@ -69,11 +77,17 @@
(define-on-demand meta-color (make-racket-style "RktMeta")) (define-on-demand meta-color (make-racket-style "RktMeta"))
(define-on-demand value-color (make-racket-style "RktVal")) (define-on-demand value-color (make-racket-style "RktVal"))
(define-on-demand symbol-color (make-racket-style "RktSym")) (define-on-demand symbol-color (make-racket-style "RktSym"))
(define-on-demand symbol-def-color (make-racket-style "RktSymDef"
#:extras (list (attributes '((class . "RktSym"))))))
(define-on-demand variable-color (make-racket-style "RktVar")) (define-on-demand variable-color (make-racket-style "RktVar"))
(define-on-demand opt-color (make-racket-style "RktOpt")) (define-on-demand opt-color (make-racket-style "RktOpt"))
(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f)) (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
(define-on-demand syntax-link-color (make-racket-style "RktStxLink")) (define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
(define-on-demand value-link-color (make-racket-style "RktValLink")) (define-on-demand value-link-color (make-racket-style "RktValLink"))
(define-on-demand syntax-def-color (make-racket-style "RktStxDef"
#:extras (list (attributes '((class . "RktStxLink"))))))
(define-on-demand value-def-color (make-racket-style "RktValDef"
#:extras (list (attributes '((class . "RktValLink"))))))
(define-on-demand module-color (make-racket-style "RktMod")) (define-on-demand module-color (make-racket-style "RktMod"))
(define-on-demand module-link-color (make-racket-style "RktModLink")) (define-on-demand module-link-color (make-racket-style "RktModLink"))
(define-on-demand block-color (make-racket-style "RktBlk")) (define-on-demand block-color (make-racket-style "RktBlk"))
@ -134,14 +148,15 @@
(define qq-ellipses (string->uninterned-symbol "...")) (define qq-ellipses (string->uninterned-symbol "..."))
(define (make-id-element c s) (define (make-id-element c s defn?)
(let* ([key (and id-element-cache (let* ([key (and id-element-cache
(let ([b (identifier-label-binding c)]) (let ([b (identifier-label-binding c)])
(vector (syntax-e c) (vector (syntax-e c)
(module-path-index->taglet (caddr b)) (module-path-index->taglet (caddr b))
(cadddr b) (cadddr b)
(list-ref b 5) (list-ref b 5)
(syntax-property c 'display-string))))]) (syntax-property c 'display-string)
defn?)))])
(or (and key (or (and key
(let ([b (hash-ref id-element-cache key #f)]) (let ([b (hash-ref id-element-cache key #f)])
(and b (and b
@ -154,9 +169,17 @@
(list (list
(case (car tag) (case (car tag)
[(form) [(form)
(make-link-element syntax-link-color (nonbreak-leading-hyphens s) tag)] (make-link-element (if defn?
syntax-def-color
syntax-link-color)
(nonbreak-leading-hyphens s)
tag)]
[else [else
(make-link-element value-link-color (nonbreak-leading-hyphens s) tag)]))) (make-link-element (if defn?
value-def-color
value-link-color)
(nonbreak-leading-hyphens s)
tag)])))
(list (list
(make-element "badlink" (make-element "badlink"
(make-element value-link-color s)))))) (make-element value-link-color s))))))
@ -201,7 +224,7 @@
[(str val) (datum-intern-literal (format str val))] [(str val) (datum-intern-literal (format str val))]
[(str . vals) (datum-intern-literal (apply format str vals))])) [(str . vals) (datum-intern-literal (apply format str vals))]))
(define (typeset-atom c out color? quote-depth expr? escapes?) (define (typeset-atom c out color? quote-depth expr? escapes? defn?)
(if (and (var-id? (syntax-e c)) (if (and (var-id? (syntax-e c))
(zero? quote-depth)) (zero? quote-depth))
(out (iformat "~s" (let ([v (var-id-sym (syntax-e c))]) (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
@ -252,8 +275,11 @@
(quote-depth . <= . 0) (quote-depth . <= . 0)
(not (or it? is-var?))) (not (or it? is-var?)))
(if (pair? (identifier-label-binding c)) (if (pair? (identifier-label-binding c))
(make-id-element c s) (make-id-element c s defn?)
(nonbreak-leading-hyphens s)) (let ([c (nonbreak-leading-hyphens s)])
(if defn?
(make-element symbol-def-color c)
c)))
(literalize-spaces s #t)) (literalize-spaces s #t))
(cond (cond
[(positive? quote-depth) value-color] [(positive? quote-depth) value-color]
@ -284,7 +310,7 @@
(define omitable (make-style #f '(omitable))) (define omitable (make-style #f '(omitable)))
(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? elem-wrap) (define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[content null] [content null]
[docs null] [docs null]
@ -406,7 +432,7 @@
(if val? value-color #f) (if val? value-color #f)
(list (list
(make-element/cache (if val? value-color paren-color) '". ") (make-element/cache (if val? value-color paren-color) '". ")
(typeset a #f "" "" "" (not val?) expr? escapes? elem-wrap) (typeset a #f "" "" "" (not val?) expr? escapes? defn? elem-wrap)
(make-element/cache (if val? value-color paren-color) '" .")) (make-element/cache (if val? value-color paren-color) '" ."))
(+ (syntax-span a) 4))) (+ (syntax-span a) 4)))
(list (syntax-source a) (list (syntax-source a)
@ -818,11 +844,11 @@
[(and (keyword? (syntax-e c)) expr?) [(and (keyword? (syntax-e c)) expr?)
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(typeset-atom c out color? quote-depth expr? escapes?) (typeset-atom c out color? quote-depth expr? escapes? defn?)
(set! src-col (+ src-col (or (syntax-span c) 1))))] (set! src-col (+ src-col (or (syntax-span c) 1))))]
[else [else
(advance c init-line!) (advance c init-line!)
(typeset-atom c out color? quote-depth expr? escapes?) (typeset-atom c out color? quote-depth expr? escapes? defn?)
(set! src-col (+ src-col (or (syntax-span c) 1))) (set! src-col (+ src-col (or (syntax-span c) 1)))
#; #;
(hash-set! next-col-map src-col dest-col)]))) (hash-set! next-col-map src-col dest-col)])))
@ -844,7 +870,7 @@
(make-table block-color (map list (reverse docs)))) (make-table block-color (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col)))) (make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? elem-wrap) (define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[s (syntax-e c)]) [s (syntax-e c)])
(if (or multi-line? (if (or multi-line?
@ -861,7 +887,7 @@
(struct-proxy? s) (struct-proxy? s)
(and expr? (or (identifier? c) (and expr? (or (identifier? c)
(keyword? (syntax-e c))))) (keyword? (syntax-e c)))))
(gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? elem-wrap) (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(typeset-atom c (typeset-atom c
(letrec ([mk (letrec ([mk
(case-lambda (case-lambda
@ -874,31 +900,32 @@
(make-element/cache (and color? color) elem) (make-element/cache (and color? color) elem)
(make-sized-element (and color? color) elem len)))])]) (make-sized-element (and color? color) elem len)))])])
mk) mk)
color? 0 expr? escapes?)))) color? 0 expr? escapes? defn?))))
(define (to-element c (define (to-element c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t]) #:escapes? [escapes? #t]
(typeset c #f "" "" "" #t expr? escapes? values)) #:defn? [defn? #f])
(typeset c #f "" "" "" #t expr? escapes? defn? values))
(define (to-element/no-color c (define (to-element/no-color c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t]) #:escapes? [escapes? #t])
(typeset c #f "" "" "" #f expr? escapes? values)) (typeset c #f "" "" "" #f expr? escapes? #f values))
(define (to-paragraph c (define (to-paragraph c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t] #:escapes? [escapes? #t]
#:color? [color? #t] #:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)]) #:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t "" "" "" color? expr? escapes? elem-wrap)) (typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
(define ((to-paragraph/prefix pfx1 pfx sfx) c (define ((to-paragraph/prefix pfx1 pfx sfx) c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t] #:escapes? [escapes? #t]
#:color? [color? #t] #:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)]) #:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t pfx1 pfx sfx color? expr? escapes? elem-wrap)) (typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
(begin-for-syntax (begin-for-syntax
(define-struct variable-id (sym) (define-struct variable-id (sym)

3
pkgs/scribble-pkgs/scribble-lib/scribble/racket.tex
View File

@ -15,12 +15,15 @@
\newcommand{\RktPlain}[1]{\inColor{black}{#1}} \newcommand{\RktPlain}[1]{\inColor{black}{#1}}
\newcommand{\RktKw}[1]{{\SColorize{black}{\Scribtexttt{#1}}}} % no \textbf anymore \newcommand{\RktKw}[1]{{\SColorize{black}{\Scribtexttt{#1}}}} % no \textbf anymore
\newcommand{\RktStxLink}[1]{\RktKw{#1}} \newcommand{\RktStxLink}[1]{\RktKw{#1}}
\newcommand{\RktStxDef}[1]{\RktStxLink{#1}}
\newcommand{\RktCmt}[1]{\inColor{CommentColor}{#1}} \newcommand{\RktCmt}[1]{\inColor{CommentColor}{#1}}
\newcommand{\RktPn}[1]{\inColor{ParenColor}{#1}} \newcommand{\RktPn}[1]{\inColor{ParenColor}{#1}}
\newcommand{\RktInBG}[1]{\inColor{ParenColor}{#1}} \newcommand{\RktInBG}[1]{\inColor{ParenColor}{#1}}
\newcommand{\RktSym}[1]{\inColor{IdentifierColor}{#1}} \newcommand{\RktSym}[1]{\inColor{IdentifierColor}{#1}}
\newcommand{\RktSymDef}[1]{\RktSym{#1}}
\newcommand{\RktVal}[1]{\inColor{ValueColor}{#1}} \newcommand{\RktVal}[1]{\inColor{ValueColor}{#1}}
\newcommand{\RktValLink}[1]{\inColor{blue}{#1}} \newcommand{\RktValLink}[1]{\inColor{blue}{#1}}
\newcommand{\RktValDef}[1]{\RktValLink{#1}}
\newcommand{\RktModLink}[1]{\inColor{blue}{#1}} \newcommand{\RktModLink}[1]{\inColor{blue}{#1}}
\newcommand{\RktRes}[1]{\inColor{ResultColor}{#1}} \newcommand{\RktRes}[1]{\inColor{ResultColor}{#1}}
\newcommand{\RktOut}[1]{\inColor{OutputColor}{#1}} \newcommand{\RktOut}[1]{\inColor{OutputColor}{#1}}

5
pkgs/scribble-pkgs/scribble-lib/scribble/struct.rkt
View File

@ -101,7 +101,8 @@
(rename-out [toc-element-toc-content/compat toc-element-toc-content]) (rename-out [toc-element-toc-content/compat toc-element-toc-content])
(compat*-out [target-element (tag)] (compat*-out [target-element (tag)]
[toc-target-element ()] [toc-target-element ()]
[page-target-element ()] [toc-target2-element (toc-content)])
(compat*-out [page-target-element ()]
[redirect-target-element (alt-path alt-anchor)] [redirect-target-element (alt-path alt-anchor)]
[link-element (tag)] [link-element (tag)]
[index-element (tag plain-seq entry-seq desc)]) [index-element (tag plain-seq entry-seq desc)])
@ -299,6 +300,8 @@
(handle-image-style make-target-element style (list->content content) tag)) (handle-image-style make-target-element style (list->content content) tag))
(define (make-toc-target-element/compat style content tag) (define (make-toc-target-element/compat style content tag)
(handle-image-style make-toc-target-element style (list->content content) tag)) (handle-image-style make-toc-target-element style (list->content content) tag))
(define (make-toc-target2-element/compat style content tag toc-content)
(handle-image-style make-toc-target2-element style (list->content content) tag toc-content))
(define (make-page-target-element/compat style content tag) (define (make-page-target-element/compat style content tag)
(handle-image-style make-page-target-element style (list->content content) tag)) (handle-image-style make-page-target-element style (list->content content) tag))
(define (make-redirect-target-element/compat style content tag alt-path alt-anchor) (define (make-redirect-target-element/compat style content tag alt-path alt-anchor)