diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
index a8f5bb04..e7221f2f 100644
--- a/collects/scribble/html-render.ss
+++ b/collects/scribble/html-render.ss
@@ -106,6 +106,11 @@
#reader scribble/reader (begin ; easier to format
+(define mynoscript-setup
+ @inlined-script{
+ document.write('');
+ })
+
(define search-script
@inlined-script{
var search_nodes = null;
@@ -523,6 +528,7 @@
(meta ([http-equiv "content-type"]
[content "text-html; charset=utf-8"]))
,title
+ ,mynoscript-setup
,(scribble-css-contents style-file css-path)
,(scribble-js-contents script-file script-path))
(body () ,@(render-toc-view d ri)
@@ -703,6 +709,10 @@
[(hover-element? e)
`((span ([title ,(hover-element-text e)])
,@(render-plain-element e part ri)))]
+ [(script-element? e)
+ `((script ([type ,(script-element-type e)])
+ ,(literal (script-element-script e)))
+ (mynoscript ,@(render-plain-element e part ri)))]
[(target-element? e)
`((a ([name ,(format "~a" (anchor-name (tag-key (target-element-tag e)
ri)))]))
@@ -747,86 +757,100 @@
[else (render-plain-element e part ri)]))
(define/private (render-plain-element e part ri)
- (define style (and (element? e) (element-style e)))
- (cond
- [(symbol? style)
- (case style
- [(italic) `((i ,@(super render-element e part ri)))]
- [(bold) `((b ,@(super render-element e part ri)))]
- [(tt) `((span ([class "stt"]) ,@(super render-element e part ri)))]
- [(no-break) `((span ([class "nobreak"])
- ,@(super render-element e part ri)))]
- [(sf) `((b (font ([size "-1"] [face "Helvetica"])
- ,@(super render-element e part ri))))]
- [(subscript) `((sub ,@(super render-element e part ri)))]
- [(superscript) `((sup ,@(super render-element e part ri)))]
- [(hspace) `((span ([class "hspace"])
- ,@(let ([str (content->string (element-content e))])
- (map (lambda (c) 'nbsp) (string->list str)))))]
- [(newline) `((br))]
- [else (error 'html-render "unrecognized style symbol: ~e" style)])]
- [(string? style)
- `((span ([class ,style]) ,@(super render-element e part ri)))]
- [(and (pair? style) (memq (car style) '(color bg-color)))
- (unless (and (list? style)
- (or (and (= 4 (length style))
- (andmap byte? (cdr style)))
- (and (= 2 (length style))
- (member (cadr style)
- '("white" "black" "red" "green" "blue"
- "cyan" "magenta" "yellow")))))
- (error 'render-font "bad color style: ~e" style))
- `((font ([style
- ,(format "~acolor: ~a"
- (if (eq? (car style) 'bg-color) "background-" "")
- (if (= 2 (length style))
- (cadr style)
- (string-append*
- "#"
- (map (lambda (v)
- (let ([s (number->string v 16)])
- (if (< v 16) (string-append "0" s) s)))
- (cdr style)))))])
- ,@(super render-element e part ri)))]
- [(target-url? style)
- (if (current-no-links)
- (super render-element e part ri)
- (parameterize ([current-no-links #t])
- `((a ([href ,(let ([addr (target-url-addr style)])
- (if (path? addr)
- (from-root addr (get-dest-directory))
- addr))]
- ,@(if (string? (target-url-style style))
- `([class ,(target-url-style style)])
- null))
- ,@(super render-element e part ri)))))]
- [(url-anchor? style)
- `((a ([name ,(url-anchor-name style)])
- ,@(super render-element e part ri)))]
- [(image-file? style)
- (let* ([src (main-collects-relative->path (image-file-path style))]
- [scale (image-file-scale style)]
- [to-num
- (lambda (s)
- (number->string
- (inexact->exact
- (floor (* scale (integer-bytes->integer s #f #t))))))]
- [sz (if (= 1.0 scale)
- null
- ;; Try to extract file size:
- (call-with-input-file*
- src
- (lambda (in)
- (if (regexp-try-match #px#"^\211PNG.{12}" in)
- `([width ,(to-num (read-bytes 4 in))]
- [height ,(to-num (read-bytes 4 in))])
- null))))])
- `((img ([src ,(let ([p (install-file src)])
- (if (path? p)
- (url->string (path->url (path->complete-path p)))
- p))])
- ,@sz)))]
- [else (super render-element e part ri)]))
+ (let* ([raw-style (and (element? e) (element-style e))]
+ [style (if (with-attributes? raw-style)
+ (with-attributes-style raw-style)
+ raw-style)]
+ [attribs (lambda ()
+ (if (with-attributes? raw-style)
+ (map (lambda (p) (list (car p) (cdr p)))
+ (with-attributes-assoc raw-style))
+ null))])
+ (cond
+ [(symbol? style)
+ (case style
+ [(italic) `((i ,(attribs) ,@(super render-element e part ri)))]
+ [(bold) `((b ,(attribs) ,@(super render-element e part ri)))]
+ [(tt) `((span ([class "stt"] . ,(attribs)) ,@(super render-element e part ri)))]
+ [(no-break) `((span ([class "nobreak"] . ,(attribs))
+ ,@(super render-element e part ri)))]
+ [(sf) `((b (font ([size "-1"] [face "Helvetica"] . ,(attribs))
+ ,@(super render-element e part ri))))]
+ [(subscript) `((sub ,(attribs) ,@(super render-element e part ri)))]
+ [(superscript) `((sup ,(attribs) ,@(super render-element e part ri)))]
+ [(hspace) `((span ([class "hspace"] . ,(attribs))
+ ,@(let ([str (content->string (element-content e))])
+ (map (lambda (c) 'nbsp) (string->list str)))))]
+ [(newline) `((br ,(attribs)))]
+ [else (error 'html-render "unrecognized style symbol: ~e" style)])]
+ [(string? style)
+ `((span ([class ,style] . ,(attribs)) ,@(super render-element e part ri)))]
+ [(and (pair? style) (memq (car style) '(color bg-color)))
+ (unless (and (list? style)
+ (or (and (= 4 (length style))
+ (andmap byte? (cdr style)))
+ (and (= 2 (length style))
+ (member (cadr style)
+ '("white" "black" "red" "green" "blue"
+ "cyan" "magenta" "yellow")))))
+ (error 'render-font "bad color style: ~e" style))
+ `((font ([style
+ ,(format "~acolor: ~a"
+ (if (eq? (car style) 'bg-color) "background-" "")
+ (if (= 2 (length style))
+ (cadr style)
+ (string-append*
+ "#"
+ (map (lambda (v)
+ (let ([s (number->string v 16)])
+ (if (< v 16) (string-append "0" s) s)))
+ (cdr style)))))]
+ . ,(attribs))
+ ,@(super render-element e part ri)))]
+ [(target-url? style)
+ (if (current-no-links)
+ (super render-element e part ri)
+ (parameterize ([current-no-links #t])
+ `((a ([href ,(let ([addr (target-url-addr style)])
+ (if (path? addr)
+ (from-root addr (get-dest-directory))
+ addr))]
+ ,@(if (string? (target-url-style style))
+ `([class ,(target-url-style style)])
+ null)
+ . ,(attribs))
+ ,@(super render-element e part ri)))))]
+ [(url-anchor? style)
+ `((a ([name ,(url-anchor-name style)] . ,(attribs))
+ ,@(super render-element e part ri)))]
+ [(image-file? style)
+ (let* ([src (main-collects-relative->path (image-file-path style))]
+ [scale (image-file-scale style)]
+ [to-num
+ (lambda (s)
+ (number->string
+ (inexact->exact
+ (floor (* scale (integer-bytes->integer s #f #t))))))]
+ [sz (if (= 1.0 scale)
+ null
+ ;; Try to extract file size:
+ (call-with-input-file*
+ src
+ (lambda (in)
+ (if (regexp-try-match #px#"^\211PNG.{12}" in)
+ `([width ,(to-num (read-bytes 4 in))]
+ [height ,(to-num (read-bytes 4 in))])
+ null))))])
+ `((img ([src ,(let ([p (install-file src)])
+ (if (path? p)
+ (url->string (path->url (path->complete-path p)))
+ p))]
+ . ,(attribs))
+ ,@sz)))]
+ [else
+ (if (with-attributes? raw-style)
+ `((span ,(attribs) ,@(super render-element e part ri)))
+ (super render-element e part ri))])))
(define/override (render-table t part ri need-inline?)
(define t-style (table-style t))
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
index 4a1d7e23..22d95211 100644
--- a/collects/scribble/manual.ss
+++ b/collects/scribble/manual.ss
@@ -334,8 +334,11 @@
(define (procedure . str)
(make-element "schemeresult" `("#")))
-(define (link url #:underline? [underline? #t] . str)
- (make-element (make-target-url url (if underline? #f "plainlink"))
+(define (link url
+ #:underline? [underline? #t]
+ #:style [style (if underline? #f "plainlink")]
+ . str)
+ (make-element (make-target-url url style)
(decode-content str)))
(define (schemeerror . str)
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
index 6b77067f..a9917d94 100644
--- a/collects/scribble/struct.ss
+++ b/collects/scribble/struct.ss
@@ -161,8 +161,13 @@
[desc any/c])]
[(aux-element element) ()]
[(hover-element element) ([text string?])]
+ [(script-element element) ([type string?]
+ [script string?])]
;; specific renders support other elements, especially strings
+ [with-attributes ([style any/c]
+ [assoc (listof (cons/c symbol? string?))])]
+
[collected-info ([number (listof (or/c false/c integer?))]
[parent (or/c false/c part?)]
[info any/c])]
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
index a69ccd7b..87e37095 100644
--- a/collects/scribblings/scribble/manual.scrbl
+++ b/collects/scribblings/scribble/manual.scrbl
@@ -791,9 +791,14 @@ The @tech{decode}d @scheme[pre-content] is hyperlinked to the definition
of @scheme[id].}
-@defproc[(link [url string?] [pre-content any/c] ...) element?]{
+@defproc[(link [url string?] [pre-content any/c] ...
+ [#:underline? underline? any/c #t]
+ [#:style style any/c (if underline? #f "plainlink")])
+ element?]{
-The @tech{decode}d @scheme[pre-content] is hyperlinked to @scheme[url].}
+The @tech{decode}d @scheme[pre-content] is hyperlinked to
+@scheme[url]. If @scheme[style] is not supplied, then
+@scheme[underline?] determines how the link is rendered.}
@defproc[(elemtag [t tag?] [pre-content any/c] ...) element?]{
diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl
index 78adb0ac..c8a5f233 100644
--- a/collects/scribblings/scribble/struct.scrbl
+++ b/collects/scribblings/scribble/struct.scrbl
@@ -143,6 +143,18 @@ A @deftech{block} is either a @techlink{table}, an
excluded in the text of a link when it
appears in a referenced section name.}
+ @item{An instance of @scheme[hover-element] adds
+ text to show in render HTML when the mouse
+ hovers over the elements.}
+
+ @item{An instance of @scheme[script-element]
+ provides script code (usually
+ @as-index{Javascript}) to run in the browser
+ to generate the element; the element's normal
+ content is used when scripting is disabled in
+ the browser, or for rendering to other
+ formats.}
+
}}}}
@item{A @deftech{delayed block} is an instance of
@@ -361,7 +373,8 @@ The @scheme[style] field is normally either
@itemize{
- @item{a string, which corresponds to a CSS class for HTML output;}
+ @item{a string, which corresponds to a CSS class for HTML output and
+ a macro name for Latex output;}
@item{one of the symbols that all renderers recognize: @scheme['tt],
@scheme['italic], @scheme['bold], @scheme['sf],
@@ -382,9 +395,12 @@ The @scheme[style] field is normally either
background color (with the same constraints and meanings as for
@scheme['color]);}
- @item{an instance of @scheme[target-url] to generate a hyperlink; or}
+ @item{an instance of @scheme[target-url] to generate a hyperlink;}
- @item{an instance of @scheme[image-file] to support an inline image.}
+ @item{an instance of @scheme[image-file] to support an inline image; or}
+
+ @item{an instance of @scheme[with-attributes], which combines a base
+ style with a set of additional HTML attributes.}
}
@@ -461,6 +477,21 @@ Instances of this structure type are intended for use in titles, where
}
+@defstruct[(hover-element element) ([text string?])]{
+
+The @scheme[text] is displayed in HTML output when the mouse hovers
+over the element's content.}
+
+
+@defstruct[(script-element element) ([type string?]
+ [script string?])]{
+
+For HTML rendering, when scripting is enabled in the browser,
+@scheme[script] is used for the element instead of its normal
+content. The @scheme[type] string is normally
+@scheme["text/javascript"].}
+
+
@defstruct[delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any/c)]
[plain (-> any/c)])]{
@@ -512,6 +543,11 @@ element remains intact (i.e., it is not replaced) by either the
}
+@defstruct[with-attributes ([style any/c]
+ [assoc (listof (cons/c symbol? string?))])]{
+
+Used for an @scheme[element]'s style to combine a base style with
+arbitrary HTML attributes.}
@defstruct[collected-info ([number (listof (or/c false/c integer?))]